packages feed

quickspec 0.9.6 → 2.2

raw patch · 68 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009-2014, Nick Smallbone+Copyright (c) 2009-2018, Nick Smallbone  All rights reserved.
− README.asciidoc 
@@ -1,410 +0,0 @@-:replacements.DOCS: http://hackage.haskell.org/package/quickspec-0.9.5/docs/Test-QuickSpec.html-:replacements.PAPER: http://www.cse.chalmers.se/~nicsma/papers/quickspec.pdf-:replacements.FUN: http://hackage.haskell.org/package/quickspec-0.9.5/docs/Test-QuickSpec.html#v:-:replacements.TYPE: http://hackage.haskell.org/package/quickspec-0.9.5/docs/Test-QuickSpec.html#t:-:replacements.EXAMPLE: link:examples/--QuickSpec: equational laws for free!-====================================--Ever get that nagging feeling that your code must satisfy some-algebraic properties, but not sure what they are? Want to write some-QuickCheck properties, but not sure where to start? QuickSpec might be-for you! Give it your program -- QuickSpec will find the laws it obeys.--QuickSpec takes any hodgepodge of functions, and tests those functions-to work out the relationship between them. It then spits out what it-discovered as a list of equations.--Give QuickSpec `reverse`, `++` and `[]`, for example, and it will find-six laws:---------------------------------------------------xs++[] == xs-[]++xs == xs-(xs++ys)++zs == xs++(ys++zs)-reverse [] == []-reverse (reverse xs) == xs-reverse xs++reverse ys == reverse (ys++xs)---------------------------------------------------All the laws you would expect to hold, and nothing more -- and all-discovered automatically! Brill!--Where's the catch? While QuickSpec is pretty nifty, it isn't magic,-and has a number of limitations:--* QuickSpec can only discover _equations_, not other kinds of laws.-  Luckily, equations cover a lot of what you would normally want to-  say about Haskell programs. Often, even if a law you want isn't-  equational, QuickSpec will discover equational special cases of that-  law which suggest the general case.-* You have to tell QuickSpec exactly which functions and constants it-  should consider when generating laws. In the example above, we gave-  `reverse`, `++` and `[]`, and those are the _only_ functions that-  appear in the six equations. For example, we don't get the equation-  `(x:xs)++ys == x:(xs++ys)`, because we didn't include +:+ in the-  functions we gave to QuickSpec. A large part of using QuickSpec-  effectively is choosing which functions to consider in laws.-* QuickSpec exhaustively enumerates terms, so it will only discover-  equations about small(ish) terms -- in fact, terms up to a fixed-  depth. You can adjust the maximum depth but, as QuickSpec exhaustively-  enumerates terms, there is an exponential blowup as you increase the-  depth. Likewise, there is an exponential blowup as you give QuickSpec-  more functions to consider (though it doesn't blow up as badly as-  you might think!)-* QuickSpec only tests the laws, it doesn't try to prove them.-  So while the generated laws are very likely to be true, there is-  still a chance that they are false, especially if your test data-  generation is not up to scratch.--Despite these limitations, QuickSpec works well on many examples.--The rest of this +README+ introduces QuickSpec through a couple of short examples.-You can look at the bottom of this file for links to more examples, Haddock documentation and our paper about QuickSpec.--Installing-------------Install QuickSpec in the usual way -- `cabal install quickspec`.--Booleans -- the basics-------------------------Let's start by testing some boolean operators.--To run QuickSpec, we must define a _signature_, which specifies which-functions we want to test, together with the variables that can appear-in the generated equations. Here is our signature:--[source,haskell]--------------------------------------------------bools = [-  ["x", "y", "z"] `vars` (undefined :: Bool),--  "||"    `fun2` (||),-  "&&"    `fun2` (&&),-  "not"   `fun1` not,-  "True"  `fun0` True,-  "False" `fun0` False]---------------------------------------------------In the signature, we define three variables (+x+, +y+ and +z+) of type-+Bool+, using the FUNvars[`vars`] combinator, which takes two-parameters: a list of variable names, and the type we want those-variables to have. We also give give QuickSpec the functions +||+,-+&&+, +not+, +True+ and +False+, using the-FUNfun0[`fun0`]/FUNfun1[`fun1`]/FUNfun2[`fun2`] combinators. These-take two parameters: the name of the function, and the function-itself. The integer, +0+, +1+ or +2+ here, is the arity of the-function.--Having written this signature, we can invoke QuickSpec just by calling-the function FUNquickSpec[`quickSpec`]:--[source,haskell]--------------------------------------------------import Test.QuickSpec hiding (bools)-main = quickSpec bools---------------------------------------------------You can find this code in EXAMPLEBools.hs[examples/Bools.hs] in-the QuickSpec distribution. Go on, run it! (Compile it or else it'll go slow.)-You will see that QuickSpec prints out:--1. The signature it's testing, i.e. the types of all functions and-   variables. If something fishy is happening, check that the-   functions and types match up with what you expect! QuickSpec will-   also print a warning here if something seems fishy about the-   signature, e.g. if there are no variables of a certain type.-2. A summary of how much testing it did.-3. The equations it found -- the exciting bit!-   The equations are grouped according to which function they-   talk about, with equations that relate several functions at the end.--Peering through what QuickSpec found, you should see the familiar laws-of Boolean algebra. The only oddity is the equation +x||(y||z) ==-y||(x||z)+. This is QuickSpec's rather eccentric way of expressing-that +||+ is associative -- in the presence of the law +x||y == y||x+,-it's equivalent to associativity, and QuickSpec happens to choose this-formulation rather than the more traditional one. All the other laws-are just as we would expect, though. Not bad for 5 minutes' work!--Lists -- polymorphic functions and the prelude-------------------------------------------------Now let's try testing some list functions -- perhaps just `reverse`,-`++` and `[]`. We might start by writing a signature by analogy with-the earlier booleans example:--[source,haskell]------lists = [-  ["xs", "ys", "zs"] `vars` (undefined :: [a]),--  "[]"      `fun0` [],-  "reverse" `fun1` reverse,-  "++"      `fun2` (++)]-------Unfortunately, QuickSpec only supports _monomorphic_ functions. The-functions and variables in the `lists` signature are polymorphic,-and GHC complains:-------No instance for (Arbitrary a0) arising from a use of `vars'-The type variable `a0' is ambiguous-------The solution is to monomorphise the signature ourselves. QuickSpec-provides types called TYPEA[`A`], TYPEB[`B`] and TYPEC[`C`] for that-purpose, so we simply specialise all type variables to TYPEA[`A`]:--[source,haskell]------lists = [-  ["xs", "ys", "zs"] `vars` (undefined :: [A]),--  "[]"      `fun0` ([] :: [A]),-  "reverse" `fun1` (reverse :: [A] -> [A]),-  "++"      `fun2` ((++) :: [A] -> [A] -> [A])]-------Having done that, we get the six laws from the beginning of this file.--Perhaps we now decide we want laws about `length` too. We want to keep-our existing list functions in the signature, so that we get laws-relating them to `length`, but on the other hand we only want to see-new laws, i.e. the ones that mention `length`. We can do this by-marking the existing functions as _background functions_, and the-resulting signature looks as follows:--[source,haskell]------lists = [-  ["xs", "ys", "zs"] `vars` (undefined :: [A]),--  background [-    "[]"      `fun0` ([] :: [A]),-    "reverse" `fun1` (reverse :: [A] -> [A]),-    "++"      `fun2` ((++) :: [A] -> [A] -> [A])],-  "length" `fun1` (length :: [A] -> Int)]-------QuickSpec will only print an equation if it involves at least one-non-background function, in this case `length`. Running QuickSpec-again we get the following two laws:-------length (reverse xs) == length xs-length (xs++ys) == length (ys++xs)-------The first equation is all very well and good, but the second one is a-bit unsatisfying. Wouldn't we rather get-`length (xs++ys) = length xs + length ys`? To get that equation, we need to add-`(+) :: Int -> Int -> Int` to the signature. Adding it as a background-function gives us the law we want.--You often need a wide variety of background functions to get good-equations out of QuickSpec, and it gets a bit tedious declaring them-all by hand. To help you with this QuickSpec provides a _prelude_, a-predefined set of background functions which you can import into your-own signature. The prelude is very minimal, but includes basic boolean,-arithmetic and list functions. We can write our lists signature using-the prelude as follows:--[source,haskell]------lists = [-  prelude (undefined :: A) `without` ["[]", ":"],--  background [-    "reverse" `fun1` (reverse :: [A] -> [A])],-  "length" `fun1` (length :: [A] -> Int)]-------A call to FUNprelude[`prelude`] +(undefined :: a)+ will declare the following-background functions:-  * The boolean connectives `||`, `&&`, `not`, `True` and `False`.-  * The arithmetic operations `0`, `1`, `+` and `*` over type `Int`.-  * The list operations `[]`, `:`, `++`, `head` and `tail` over type `[a]`.-  * Three variables each of type `Bool`, `Int`, `a` and `[a]`.--In the example above we used the FUNwithout[`without`] combinator to-leave out `[]` and `:` from the prelude, so as to get fewer laws.-QuickSpec also provides the combinators FUNbools[`bools`],-FUNarith[`arith`] and FUNlists[`lists`], which import only their-respective part of the prelude, for when you want more control -- see-the DOCS[documentation] for more information.--In EXAMPLELists.hs[Lists.hs] you can find an extended version-of the above example which also tests `map`.--Advanced: function composition -- testing types with no `Ord` instance-------------------------------------------------------------------------WARNING: this section isn't finished.--IMPORTANT: You can skip this section unless you need to test a type-with no `Ord` instance.--Suppose we want to get QuickSpec to discover the laws of function-composition -- things like `id . f == f`.--If we just define a signature containing `id` and `(.)` (and suitable-variables), the output is rather disappointing:-------(f . g) x == f (g x)-id x == x-------This is because QuickSpec is giving us laws about _fully saturated_-applications of `(.)` and `id`, that is, `(.)` applied to three-arguments and `id` applied to one argument. In the laws we are after,-we only want to apply `(.)` to two arguments, and we don't want to-apply `id` to an argument at all. To fix this we can declare `(.)`-to have arity 2 and `id` to have arity 1, so that QuickSpec won't-fully apply them:-------composition = [-  vars ["f", "g", "h"] (undefined :: A -> A),-  fun2 "."   ((.) :: (A -> A) -> (A -> A) -> (A -> A)),-  fun0 "id"  (id  :: A -> A),-  ]-------Unfortunately, we get the following error message:-------Could not deduce (Ord (A -> A)) arising from a use of `fun2'-------To test a law like `id . f == f`, QuickSpec generates a random value-for `f` and then just evaluates the expression `id . f == f` to get-either `True` or `False`.--The error message complains that we are trying to generate laws about-terms of the type `A -> A` (i.e. functions), but as there is no `Ord`-instance for functions QuickSpec has no way of testing the laws.-QuickSpec tests a law like `id . f == f` by generating random values-for `f` and seeing if the resulting left-hand side and right-hand side-evaluate to the same value; it can only do this if it has an `Ord`-instance for the values in question. As there is no way to tell if-two functions are equal, it seems we are stuck!--Hang on, though. We can still _test_ if two functions are equal:-generate a random argument and apply the two functions to it, and see-if they both give the same result. If they don't, they're certainly-not equal. Repeat the process a few times, for several random-arguments, and if both functions always seem to give the same result-then they're probably equal.----This is a common situation -- we have a type, we cannot directly-compare values of that type, but we can make random _observations_-and compare those. For our example, observing a function consists-of applying the function to a random argument. QuickSpec supports-finding equations over types that you can observe. The-observations must satisfy the following properties:--* The observation returns a value of a type that we can directly-  compare for equality.-* If two values are different, there is an observation that-  distinguishes them.-* If an observation distinguishes two values, they are not equal.----Common pitfalls------------------WARNING: this section isn't finished.--*I get laws which seem to be false!*-If a law really is false, it means that QuickCheck didn't discover the-counterexample to it. Possible solutions include:--  * Improve the test data generation. If you can't change the-    Arbitrary` instance for your type, you can use the-    FUNgvars[`gvars`] combinator, which is like FUNvars[`vars`]-    but allows you to specify the generator.-  * If you are testing a polymorphic function, try instantiating it-    with the QuickSpec type TYPETwo[`Two`] instead of TYPEA[`A`].-    TYPETwo[`Two`] is a type that has only two elements, which may-    make it easier to hit counterexamples.-  * Use the FUNwithTests[`withTests`] combinator to increase the-    number of tests.--*QuickSpec runs for a very long time without terminating!*-QuickSpec works by enumerating all terms up to a certain depth,-and therefore suffers from exponential blowup. Check the output-where it reports how many terms it generated:-------== Testing ==-Depth 1: 6 terms, 4 tests, 18 evaluations, 6 classes, 0 raw equations.-Depth 2: 61 terms, 500 tests, 28568 evaluations, 15 classes, 46 raw equations.-Depth 3: 412 terms, 500 tests, 205912 evaluations, 53 classes, 359 raw equations.-------Here it's generated 412 terms. If the number gets much above 100,000-then you will probably run into trouble. This can be caused by one of-several things:-  * Too many functions in the signature.--*I only get ground instances of the laws I want!*--Perhaps you forgot to add--no variables--*Law not found*--Is it true? Is it provable? Are all necessary functions in the signature?-Do the types match up so that the term is well-typed?--*Get false laws*--Tweak test data generators--*Exponential blowup*--*I want to test a datatype with no `Ord` instance, such as functions*--see function composition-----A common mistake when using QuickSpec is to forget to define any-variables of a certain type. In that case, you will typically get lots-of special cases instead of the law you really want. For example,-------True||True == True-True||False == True-False||True == True-False||False == False-------Where to go from here?-----------------------Have a look at the examples that come with QuickSpec:--* link:examples/Bools.hs[Booleans]-* link:examples/Arith.hs[Arithmetic]-* link:examples/Lists.hs[List functions]-* link:examples/Heaps.hs[Binary heaps]-* link:examples/Composition.hs[Function composition]-* link:examples/Arrays.hs[Arrays]-* link:examples/TinyWM.hs[A tiny window manager]-* link:examples/PrettyPrinting.hs[Pretty-printing combinators]--Read our PAPER[paper].--Read the DOCS[Haddock documentation] for things to tweak.
+ README.md view
@@ -0,0 +1,28 @@+QuickSpec: equational laws for free!+====================================++QuickSpec takes your Haskell code and, as if by magic, discovers laws about it.+You give QuickSpec a collection of Haskell functions; QuickSpec tests your functions+with QuickCheck and prints out laws which seem to hold.++For example, give QuickSpec the functions `reverse`, `++` and `[]`, and it will+find six laws:++```haskell+reverse [] == []+xs ++ [] == xs+[] ++ xs == xs+reverse (reverse xs) == xs+(xs ++ ys) ++ zs == xs ++ (ys ++ zs)+reverse xs ++ reverse ys == reverse (ys ++ xs)+```++QuickSpec can find equational laws as well as conditional equations. All you+need to supply are the functions to test, as well as `Ord` and `Arbitrary`+instances for QuickSpec to use in testing; the rest is automatic.++For information on how to use QuickSpec, see+[the documentation](http://hackage.haskell.org/package/quickspec/docs/QuickSpec.html).+You can also look in the `examples` directory, for example at+`List.hs`, `IntSet.hs`, or `Parsing.hs`. To read about how QuickSpec works, see+our paper, [Quick specifications for the busy programmer](http://www.cse.chalmers.se/~nicsma/papers/quickspec2.pdf).
examples/Arith.hs view
@@ -1,18 +1,8 @@--- Natural number functions.--{-# LANGUAGE ScopedTypeVariables #-}--import Test.QuickSpec hiding (arith)-import Test.QuickCheck-import Data.Typeable--arith :: forall a. (Typeable a, Ord a, Num a, Arbitrary a) => a -> [Sig]-arith _ = [-  ["x", "y", "z"] `vars` (undefined :: a),--  "0" `fun0` (0   :: a),-  "1" `fun0` (1   :: a),-  "+" `fun2` ((+) :: a -> a -> a),-  "*" `fun2` ((*) :: a -> a -> a)]+-- A simple example testing arithmetic functions.+import QuickSpec -main = quickSpec (arith (undefined :: Int))+main = quickSpec [+  con "0" (0 :: Int),+  con "1" (1 :: Int),+  con "+" ((+) :: Int -> Int -> Int),+  con "*" ((*) :: Int -> Int -> Int) ]
− examples/Arrays.hs 
@@ -1,44 +0,0 @@--- Arrays.--{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, DeriveDataTypeable #-}-import Test.QuickCheck-import Test.QuickSpec-import Data.Typeable-import Data.Array--put :: Ix i => i -> a -> Array i a -> Array i a-put ix v arr = arr // [(ix, v)]--arrays :: forall a. (Typeable a, Ord a, Arbitrary a) => a -> [Sig]-arrays a = [-  -- Don't include head, or functions on natural numbers---they-  -- generate too many irrelevant terms.-  prelude (undefined :: a) `without` ["head", "*", "0", "1"],-  lists (undefined :: Int) `without` ["head"],--  ["x", "y", "z"] `vars` (undefined :: a),-  ["a"]           `vars` (undefined :: Array Int a),-  -- Generate ranges using a custom generator to improve test data-  -- distribution.-  ["r"]           `gvars` genRange,--  "!"             `fun2` ((!)       :: Array Int a -> Int -> a),-  "put"           `fun3` (put       :: Int -> a -> Array Int a -> Array Int a),-  "listArray"     `fun2` (listArray :: (Int, Int) -> [a] -> Array Int a),-  "elems"         `fun1` (elems     :: Array Int a -> [a]),-  "indices"       `fun1` (indices   :: Array Int a -> [Int])]--instance Arbitrary a => Arbitrary (Array Int a) where-  arbitrary = do-    (low, high) <- genRange-    elems <- arbitrary :: Gen (Int -> Maybe a)-    return (array (low, high) [(i, x) | i <- [low..high], Just x <- [elems i]])--genRange :: Gen (Int, Int)-genRange = do-  low <- choose (-2, 2)-  high <- fmap (low +) (choose (-1, 2))-  return (low, high)---- Use Two instead of A to improve the chance of getting the right test data.-main = quickSpec (arrays (undefined :: Two))
examples/Bools.hs view
@@ -1,14 +1,9 @@--- A simple booleans example.--import Test.QuickSpec hiding (bools)--bools = [-  ["x", "y", "z"] `vars` (undefined :: Bool),--  "||"    `fun2` (||),-  "&&"    `fun2` (&&),-  "not"   `fun1` not,-  "True"  `fun0` True,-  "False" `fun0` False]+-- Testing functions on booleans. "not x" is used as a condition.+import QuickSpec -main = quickSpec bools+main = quickSpec [+  predicate "not" not,+  con "True" True,+  con "False" False,+  con "||" (||),+  con "&&" (&&) ]
examples/Composition.hs view
@@ -1,24 +1,6 @@-{-# LANGUAGE ScopedTypeVariables #-}--import Test.QuickSpec-import Test.QuickCheck-import Data.Typeable--composition :: forall a. (Typeable a, Ord a, Arbitrary a, CoArbitrary a) =>-               a -> [Sig]-composition _ = [-  vars ["f", "g", "h"] (undefined :: a -> a),--  -- We treat . as a function of two arguments here (blind2)---i.e.,-  -- we do not generate terms of the form (f . g) x.-  blind2 "."   ((.) :: (a -> a) -> (a -> a) -> (a -> a)),--  -- Similarly, id is not treated as a function.-  blind0 "id"  (id  :: a -> a),--  -- Tell QuickSpec how to compare values of function type:-  -- i.e., generate a random argument and apply the function to it.-  observer2 $ \x (f :: a -> a) -> f x-  ]+-- Function composition.+import QuickSpec -main = quickSpec (composition (undefined :: A))+main = quickSpec [+  con "id" (id :: A -> A),+  con "." ((.) :: (B -> C) -> (A -> B) -> A -> C) ]
+ examples/Curry.hs view
@@ -0,0 +1,9 @@+import QuickSpec++main = quickSpec [+  con "curry" (curry :: ((A, B) -> C) -> A -> B -> C),+  con "fst" (fst :: (A, B) -> A),+  con "snd" (snd :: (A, B) -> B),+  con "id" (id :: A -> A),+  con "." ((.) :: (B -> C) -> (A -> B) -> A -> C),+  con "|" ((\f g x -> (f x, g x)) :: (A -> B) -> (A -> C) -> A -> (B, C))]
+ examples/Geometry.hs view
@@ -0,0 +1,140 @@+-- Henderson's functional geometry. See the QuickSpec paper.+--+-- Illustrates:+--   * Observational equality+--   * Running QuickSpec on a progressively larger set of signatures+{-# LANGUAGE DeriveDataTypeable, TypeOperators, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+import QuickSpec+import Test.QuickCheck+import qualified Data.Set as Set+import Data.Set(Set)+import Prelude hiding (flip, cycle)+import Data.Monoid+import Control.Monad+import Data.Word+import Data.Constraint++-- We use our own number type for efficiency purposes.+-- This can represent numbers of the form x/2^e where x and e are integers.+data Rat = Rat { mantissa :: Integer, exponent :: Int } deriving (Eq, Ord, Show, Typeable)+-- Rat x e = x / 2^e++rat :: Integer -> Int -> Rat+rat x e | e < 0 = error "rat: negative exponent"+rat x 0 = Rat x 0+rat x e | even x = rat (x `div` 2) (e-1)+rat x e = Rat x e++instance Arbitrary Rat where+  arbitrary = liftM2 rat arbitrary (choose (0, 10))+  shrink (Rat x e) = fmap (uncurry rat) (shrink (x, e))++instance CoArbitrary Rat where+  coarbitrary (Rat x e) = coarbitrary x . coarbitrary e++-- A class for types (like Rat) which can be added, subtracted and+-- divided by 2.+class Half a where+  zero :: a+  neg :: a -> a+  plus :: a -> a -> a+  half :: a -> a++instance Half Rat where+  zero = rat 0 0+  neg (Rat x e) = Rat (negate x) e+  plus (Rat x1 e1) (Rat x2 e2) =+    rat (x1 * 2^(e - e1) + x2 * 2^(e - e2)) e+    where+      e = e1 `max` e2+  half (Rat x e) = Rat x (e+1)++instance (Half a, Half b) => Half (a, b) where+  zero = (zero, zero)+  neg (x, y) = (neg x, neg y)+  plus (x, y) (z, w) = (plus x z, plus y w)+  half (x, y) = (half x, half y)++-- A vector is a pair of points.+type Vector = (Rat, Rat)++-- We represent a geometrical object as a triple of vectors.+-- I forget what they mean :)+-- I think two of them represent the direction of the x-axis and y-axis.+-- The word represents an abstract "drawing command".+type Object = (Vector, Vector, Vector, Word)++-- A drawing takes size and rotation information and returns a set of objects.+newtype Drawing = Drawing (Vector -> Vector -> Vector -> Objs) deriving Typeable+newtype Objs = Objs { unObjs :: Set Object } deriving (Eq, Ord, Typeable, Show)+instance Arbitrary Objs where arbitrary = fmap objs arbitrary++objs :: Set Object -> Objs+objs = Objs . Set.filter (\(_,b,c,_) -> b /= zero && c /= zero)++instance Show Drawing where+  show (Drawing x) = show (x one one one)+    where+      one = (Rat 1 0, Rat 1 0)++instance Arbitrary Drawing where+  arbitrary = do+    os <- arbitrary+    return . Drawing $ \x y z -> objs (Set.fromList [(x, y, z, o) | o <- os])+  shrink (Drawing f) =+    [ Drawing $ \x y z -> objs (Set.fromList [(x, y, z, o) | o <- objs'])+    | let os = [ o | (_, _, _, o) <- Set.toList (unObjs (f one one one)) ],+      objs' <- shrink os ]+    where+      one = (Rat 1 0, Rat 1 0)++blank :: Drawing+blank = Drawing (\_ _ _ -> objs Set.empty)++-- The primed versions of the combinators are buggy+over, beside, above, above' :: Drawing -> Drawing -> Drawing+over (Drawing p) (Drawing q) = Drawing (\a b c -> p a b c `union` q a b c)+beside (Drawing p) (Drawing q) = Drawing (\a b c -> p a (half b) c `union` q (a `plus` half b) (half b) c)+above' (Drawing p) (Drawing q) = Drawing (\a b c -> p a b (half c) `union` q (a `plus` half c) b (half c))+above (Drawing p) (Drawing q) = Drawing (\a b c -> p (a `plus` half c) b (half c) `union` q a b (half c))++union :: Objs -> Objs -> Objs+union (Objs x) (Objs y) = objs (x `Set.union` y)++rot, flip, rot45 :: Drawing -> Drawing+rot (Drawing p) = Drawing (\a b c -> p (a `plus` b) c (neg b))+flip (Drawing p) = Drawing (\a b c -> p (a `plus` b) (neg b) c)+rot45 (Drawing p) = Drawing (\a b c -> p (a `plus` half (b `plus` c)) (half (b `plus` c)) (half (c `plus` neg b)))++quartet, quartet' :: Drawing -> Drawing -> Drawing -> Drawing -> Drawing+quartet a b c d = (a `beside` b) `above` (c `beside` d)+quartet' a b c d = (a `beside` b) `above'` (c `beside` d)++cycle, cycle' :: Drawing -> Drawing+cycle x = quartet x (rot (rot (rot x))) (rot x) (rot (rot x))+cycle' x = quartet' x (rot (rot (rot x))) (rot x) (rot (rot x))++-- Observational equality for drawings.+instance Observe (Vector, Vector, Vector) Objs Drawing where+  observe (a, b, c) (Drawing d) = d a b c++main =+  quickSpec [+    inst (Sub Dict :: () :- Arbitrary Drawing),+    inst (Sub Dict :: () :- Observe (Vector, Vector, Vector) Objs Drawing),+    series [sig1, sig2, sig3, sig4, sig5, sig6, sig7] ]+  where+    -- A series of bigger and bigger signatures.+    sig1 = [con "over" over]+    sig2 = [+      con "beside" beside,+      -- con "above" above',+      con "above" above]+    sig3 = [con "rot" rot]+    sig4 = [con "flip" flip]+    sig5 = [+      con "cycle" cycle,+      -- con "cycle" cycle',+      con "quartet" quartet]+    sig6 = [con "rot45" rot45]+    sig7 = [con "blank" blank]
− examples/Heaps.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-}--import Prelude hiding (null)-import Test.QuickSpec-import Test.QuickCheck-import Data.Typeable-import Data.Ord-import qualified Data.List as L--data Heap a = Nil | Branch Int a (Heap a) (Heap a) deriving Typeable--instance Ord a => Eq (Heap a) where-  h1 == h2 = toList h1 == toList h2--instance Ord a => Ord (Heap a) where-  compare = comparing toList--instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where-  arbitrary = fmap fromList arbitrary--toList :: Ord a => Heap a -> [a]-toList h | null h = []-         | otherwise = findMin h:toList (deleteMin h)--fromList :: Ord a => [a] -> Heap a-fromList = foldr insert Nil--null :: Heap a -> Bool-null Nil = True-null _ = False--findMin :: Heap a -> a-findMin (Branch _ x _ _) = x--insert :: Ord a => a -> Heap a -> Heap a-insert x h = merge h (branch x Nil Nil)--deleteMin :: Ord a => Heap a -> Heap a-deleteMin (Branch _ _ l r) = merge l r--branch :: Ord a => a -> Heap a -> Heap a -> Heap a-branch x l r | npl l <= npl r = Branch (npl l + 1) x l r-             | otherwise = Branch (npl r + 1) x r l--merge :: Ord a => Heap a -> Heap a -> Heap a-merge Nil h = h-merge h Nil = h-merge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2)- | x1 <= x2 = branch x1 (merge l1 h2) r1- | otherwise = merge h2 h1--npl :: Heap a -> Int-npl Nil = 0-npl (Branch n _ _ _) = n--mergeLists :: Ord a => [a] -> [a] -> [a]-mergeLists [] xs = xs-mergeLists xs [] = xs-mergeLists (x:xs) (y:ys)-  | x < y = x:mergeLists xs (y:ys)-  | otherwise = y:mergeLists (x:xs) ys--heaps :: forall a. (Ord a, Typeable a, Arbitrary a) => a -> [Sig]-heaps a = [-  prelude a,--  ["h", "h1", "h2"] `vars` (undefined :: Heap a),--  "nil"        `fun0` (Nil        :: Heap a),-  "insert"     `fun2` (insert     :: a -> Heap a -> Heap a),-  "findMin"    `fun1` (findMin    :: Heap a -> a),-  "deleteMin"  `fun1` (deleteMin  :: Heap a -> Heap a),-  "merge"      `fun2` (merge      :: Heap a -> Heap a -> Heap a),-  "null"       `fun1` (null       :: Heap a -> Bool),-  "fromList"   `fun1` (fromList   :: [a] -> Heap a),--  -- A few more list functions that are helpful for getting-  -- laws about toList/fromList.-  -- We use "background" to mark the functions as background theory,-  -- so that we only get laws that involve one of the heap functions.-  -- toList is marked as background to make the presentation of the-  -- equations a bit prettier: laws about e.g. findMin and toList-  -- will appear in QuickSpec's "Equations about findMin" section-  -- rather than "Equations about several functions".-  background [-  "toList"     `fun1` (toList     :: Heap a -> [a]),-  "sort"       `fun1` (L.sort     :: [a] -> [a]),-  "insertList" `fun2` (L.insert   :: a -> [a] -> [a]),-  "nullList"   `fun1` (L.null     :: [a] -> Bool),-  "deleteList" `fun2` (L.delete   :: a -> [a] -> [a]),-  "mergeLists" `fun2` (mergeLists :: [a] -> [a] -> [a])]]--main = quickSpec (heaps (undefined :: A))
+ examples/HugeLists.hs view
@@ -0,0 +1,41 @@+-- A stress test using lots and lots of list functions.+{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RankNTypes, ConstraintKinds, FlexibleContexts #-}+import QuickSpec+import QuickSpec.Internal.Utils+import Data.List+import Control.Monad++main = quickSpec [+  con "length" (length :: [A] -> Int),+  con "sort" (sort :: [Int] -> [Int]),+  con "scanr" (scanr :: (A -> B -> B) -> B -> [A] -> [B]),+  con "succ" (succ :: Int -> Int),+  con ">>=" ((>>=) :: [A] -> (A -> [B]) -> [B]),+  con "snd" (snd :: (A, B) -> B),+  con "reverse" (reverse :: [A] -> [A]),+  con "0" (0 :: Int),+  con "," ((,) :: A -> B -> (A, B)),+  con ">=>" ((>=>) :: (A -> [B]) -> (B -> [C]) -> A -> [C]),+  con ":" ((:) :: A -> [A] -> [A]),+  con "break" (break :: (A -> Bool) -> [A] -> ([A], [A])),+  con "filter" (filter :: (A -> Bool) -> [A] -> [A]),+  con "scanl" (scanl :: (B -> A -> B) -> B -> [A] -> [B]),+  con "zipWith" (zipWith :: (A -> B -> C) -> [A] -> [B] -> [C]),+  con "concat" (concat :: [[A]] -> [A]),+  con "zip" (zip :: [A] -> [B] -> [(A, B)]),+  con "usort" (usort :: [Int] -> [Int]),+  con "sum" (sum :: [Int] -> Int),+  con "++" ((++) :: [A] -> [A] -> [A]),+  con "map" (map :: (A -> B) -> [A] -> [B]),+  con "foldl" (foldl :: (B -> A -> B) -> B -> [A] -> B),+  con "takeWhile" (takeWhile :: (A -> Bool) -> [A] -> [A]),+  con "foldr" (foldr :: (A -> B -> B) -> B -> [A] -> B),+  con "drop" (drop :: Int -> [A] -> [A]),+  con "dropWhile" (dropWhile :: (A -> Bool) -> [A] -> [A]),+  con "span" (span :: (A -> Bool) -> [A] -> ([A], [A])),+  con "unzip" (unzip :: [(A, B)] -> ([A], [B])),+  con "+" ((+) :: Int -> Int -> Int),+  con "[]" ([] :: [A]),+  con "partition" (partition :: (A -> Bool) -> [A] -> ([A], [A])),+  con "fst" (fst :: (A, B) -> A),+  con "take" (take :: Int -> [A] -> [A]) ]
+ examples/IntSet.hs view
@@ -0,0 +1,24 @@+-- Laws about Data.IntSet.+-- Illustrates user-defined data types.+import QuickSpec+import qualified Data.IntSet as IntSet+import Data.IntSet(IntSet)++main = quickSpec [+  monoType (Proxy :: Proxy IntSet),+  withMaxTests 10000,++  series [sig1, sig2, sig3]]+  where+    sig1 = [+      con "union" IntSet.union,+      con "intersection" IntSet.intersection,+      con "empty" IntSet.empty ]+    +    sig2 = [+      con "insert" IntSet.insert,+      con "delete" IntSet.delete ]++    sig3 = [+      con "False" False,+      predicate "member" IntSet.member ]
+ examples/ListMonad.hs view
@@ -0,0 +1,10 @@+-- The monad laws for lists.+import Control.Monad+import QuickSpec++main = quickSpec [+  withMaxTestSize 20,+  con "return" (return :: A -> [A]),+  con ">>=" ((>>=) :: [A] -> (A -> [B]) -> [B]),+  con "++" ((++) :: [A] -> [A] -> [A]),+  con ">=>" ((>=>) :: (A -> [B]) -> (B -> [C]) -> A -> [C]) ]
examples/Lists.hs view
@@ -1,21 +1,14 @@-{-# LANGUAGE ScopedTypeVariables #-}--import Test.QuickSpec hiding (lists)-import Test.QuickCheck-import Data.Typeable--lists :: forall a. (Typeable a, Ord a, Arbitrary a, CoArbitrary a) =>-         a -> [Sig]-lists a = [-  prelude (undefined :: a) `without` ["++"],-  funs (undefined :: a),+-- Some usual list functions.+{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RankNTypes, ConstraintKinds, FlexibleContexts #-}+import QuickSpec -  "unit"    `fun1` (return  :: a -> [a]),-  -- Don't take ++ from the prelude because we want to see laws about it-  "++"      `fun2` ((++)    :: [a] -> [a] -> [a]),-  "length"  `fun1` (length  :: [a] -> Int),-  "reverse" `fun1` (reverse :: [a] -> [a]),-  "map"     `fun2` (map     :: (a -> a) -> [a] -> [a])-  ]+main = quickSpec [+  con "reverse" (reverse :: [A] -> [A]),+  con "++" ((++) :: [A] -> [A] -> [A]),+  con "[]" ([] :: [A]),+  con "map" (map :: (A -> B) -> [A] -> [B]),+  con "length" (length :: [A] -> Int),+  con "concat" (concat :: [[A]] -> [A]), -main = quickSpec (lists (undefined :: A))+  -- Add some numeric functions to get more laws about length.+  arith (Proxy :: Proxy Int) ]
+ examples/Octonions.hs view
@@ -0,0 +1,60 @@+-- The octonions, made using the Cayley-Dickson construction.+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleInstances #-}+import Data.Ratio+import QuickSpec+import Test.QuickCheck+import Twee.Pretty+import Control.Monad+import Data.Proxy++newtype SmallRational = SmallRational Rational+  deriving (Eq, Ord, Num, Typeable, Fractional, Conj, CoArbitrary, Show)+instance Arbitrary SmallRational where+  arbitrary = SmallRational <$> liftM2 (%) arbitrary (arbitrary `suchThat` (/= 0))++-- A class for types with conjugation, a norm operator and a generator.+class Fractional a => Conj a where+  conj :: a -> a+  norm :: a -> Rational+  it :: Gen a++instance Conj Rational where+  conj x = x+  norm x = x*x+  -- Only generate small rationals for efficiency.+  it = liftM2 (Prelude./) (elements [-10..10]) (elements [1..10])++instance Conj a => Conj (a, a) where+  conj (x, y) = (conj x, negate y)+  norm (x, y) = norm x + norm y+  it = liftM2 (,) it it++instance Conj a => Num (a, a) where+  fromInteger n = (fromInteger n, 0)+  (x, y) + (z, w) = (x + z, y + w)+  (a, b) * (c, d) = (a * c - conj d * b, d * a + b * conj c)+  negate (x, y) = (negate x, negate y)++instance Conj a => Fractional (a, a) where+  fromRational x = (fromRational x, 0)+  recip x = conj x * fromRational (recip (norm x))++newtype Complex = Complex (SmallRational, SmallRational) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show)+newtype Quaternion = Quaternion (Complex, Complex) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show)+newtype Octonion = Octonion (Quaternion, Quaternion) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show)++newtype It = It Octonion deriving (Eq, Ord, Num, Typeable, Fractional, Conj, CoArbitrary, Show)++instance Arbitrary It where+  -- Division is undefined on zero octonions.+  arbitrary = It <$> arbitrary `suchThat` (/= 0)++main = quickSpec [+  -- Make the pruner more powerful, which is helpful when Doing Maths+  withPruningTermSize 9,+  -- One test suffices :)+  withMaxTests 1,+  con "*" ((*) :: It -> It -> It),+  (con "inv" (recip :: It -> It)),+  con "1" (1 :: It),+  monoType (Proxy :: Proxy It)]
+ examples/Parsing.hs view
@@ -0,0 +1,48 @@+-- Parser combinators.+-- Illustrates observational equality with polymorphic types.+{-# LANGUAGE DeriveDataTypeable, TypeOperators, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}+import Control.Monad+import Test.QuickCheck+import QuickSpec+import Data.List+import Text.ParserCombinators.ReadP+import Data.Constraint++deriving instance Typeable ReadP++-- Generate random parsers.+instance Arbitrary a => Arbitrary (ReadP a) where+  arbitrary = fmap readS_to_P arbReadS++arbReadS :: Arbitrary a => Gen (String -> [(a, String)])+arbReadS = fmap convert (liftM2 (,) (elements [0..5]) arbitrary)+  where+    convert (n, parse) xs = take n [(x, drop n xs) | (x, n) <- parse xs]++-- Observational equality for parsers.+instance Ord a => Observe String [(a, String)] (ReadP a) where+  observe input parser = sort (readP_to_S parser input)++peek :: ReadP Char+peek = do+  (x:_) <- look+  return x++main = quickSpec [+  inst (Sub Dict :: Arbitrary A :- Arbitrary (ReadP A)),+  inst (Sub Dict :: Ord A :- Observe String [(A, String)] (ReadP A)),++  background [+    con "return" (return :: A -> ReadP A),+    con "()" (),+    con "void" (void :: ReadP A -> ReadP ()),+    con ">>=" ((>>=) :: ReadP A -> (A -> ReadP B) -> ReadP B),+    con ">=>" ((>=>) :: (A -> ReadP B) -> (B -> ReadP C) -> A -> ReadP C) ],++  con "get" get,+  con "peek" peek,+  con "+++" ((+++) :: ReadP A -> ReadP A -> ReadP A),+  con "<++" ((<++) :: ReadP A -> ReadP A -> ReadP A),+  con "pfail" (pfail :: ReadP A),+  con "eof" eof ]+
examples/PrettyPrinting.hs view
@@ -1,43 +1,70 @@-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}-module Main where-+-- Pretty-printing combinators.+-- Illustrates observational equality and using custom generators.+-- See the QuickSpec paper for more details.+{-# LANGUAGE DeriveDataTypeable, TypeOperators, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}+import Prelude hiding ((<>)) import Control.Monad-import Data.Typeable import Test.QuickCheck-import Test.QuickSpec+import QuickSpec+import Text.PrettyPrint.HughesPJ hiding (Str)+import Data.Proxy+import Data.Constraint -newtype Layout a = Layout [(Int, [a])] deriving (Typeable, Eq, Ord, Show)+deriving instance Typeable Doc -instance Arbitrary a => Arbitrary (Layout a) where-  arbitrary = fmap Layout (liftM2 (:) arbitrary arbitrary)+instance Arbitrary Doc where+  arbitrary =+    sized $ \n ->+      let bin = resize (n `div` 2) arbitrary+          un = resize (n-1) arbitrary in+      oneof $+        [ liftM2 ($$) bin bin | n > 0 ] +++        [ liftM2 (<>) bin bin | n > 0 ] +++        [ liftM2 nest arbitrary un | n > 0 ] +++        [ fmap text arbitrary ] -text :: [a] -> Layout a-text s = Layout [(0, s)]+-- Observational equality.+instance Observe Context Str Doc where+  observe (Context ctx) d = Str (render (ctx d))+newtype Str = Str String deriving (Eq, Ord) -nest :: Int -> Layout a -> Layout a-nest k (Layout l) = Layout [(i+k, s) | (i, s) <- l]+newtype Context = Context (Doc -> Doc) -($$) :: Layout a -> Layout a -> Layout a-Layout xs $$ Layout ys = Layout (xs ++ ys)+instance Arbitrary Context where+  arbitrary = Context <$> ctx+    where+      ctx =+        sized $ \n ->+        oneof $+          [ return id ] +++          [ liftM2 (\x y d -> op (x d) y) (resize (n `div` 2) ctx) (resize (n `div` 2) arbitrary) | n > 0, op <- [(<>), ($$)] ] +++          [ liftM2 (\x y d -> op x (y d)) (resize (n `div` 2) arbitrary) (resize (n `div` 2) ctx) | n > 0, op <- [(<>), ($$)] ] +++          [ liftM2 (\x y d -> nest x (y d)) arbitrary (resize (n-1) ctx) | n > 0 ] -(<>) :: Layout a -> Layout a -> Layout a-Layout xs <> Layout ys = f (init xs) (last xs) (head ys) (tail ys)-  where f xs (i, s) (j, t) ys = Layout xs $$ Layout [(i, s ++ t)] $$ nest (i + length s - j) (Layout ys)+unindented :: Doc -> Bool+unindented d = render (nest 100 (text "" <> d)) == render (nest 100 d) -pretty :: forall a. (Typeable a, Ord a, Arbitrary a) => a -> [Sig]-pretty a = [-  ["d","e","f"] `vars` (undefined :: Layout a),-  ["s","t","u"] `vars` (undefined :: [a]),-  ["n","m","o"] `vars` (undefined :: Int),-  "text" `fun1` (text :: [a] -> Layout a),-  "nest" `fun2` (nest :: Int -> Layout a -> Layout a),-  "$$" `fun2` (($$) :: Layout a -> Layout a -> Layout a),-  "<>" `fun2` ((<>) :: Layout a -> Layout a -> Layout a),+nesting :: Doc -> Int+nesting d = head [ i | i <- nums, unindented (nest (-i) d) ]+  where+    nums = 0:concat [ [i, -i] | i <- [1..] ]++main = quickSpec [+  withMaxTermSize 9,+     background [-    "[]" `fun0` ([] :: [a]),-    "++" `fun2` ((++) :: [a] -> [a] -> [a]),-    "0" `fun0` (0 :: Int),-    "length" `fun1` (length :: [a] -> Int),-    "+" `fun2` ((+) :: Int -> Int -> Int)]]+    con "[]" ([] :: [A]),+    con "++" ((++) :: [A] -> [A] -> [A]),+    con "0" (0 :: Int),+    con "+" ((+) :: Int -> Int -> Int),+    con "length" (length :: [A] -> Int) ], -main = quickSpec (pretty (undefined :: Two))++  con "text" text,+  con "nest" nest,+  --con "nesting" nesting,+  con "<>" (<>),+  con "$$" ($$),++  monoTypeObserve (Proxy :: Proxy Doc),+  defaultTo (Proxy :: Proxy Bool)]
+ examples/PrettyPrintingModel.hs view
@@ -0,0 +1,54 @@+-- Pretty-printing combinators, testing against a model implementation.+-- Illustrates running QuickSpec on a progressively larger set of signatures.+-- See the QuickSpec paper for more details.+{-# LANGUAGE DeriveDataTypeable, TypeOperators #-}+import Prelude hiding ((<>))+import Control.Monad+import Test.QuickCheck+import QuickSpec+import Data.Proxy++newtype Layout = Layout [(Int, String)]+  deriving (Typeable, Eq, Ord, Show)++instance Arbitrary Layout where+  arbitrary = fmap Layout (liftM2 (:) arbitrary arbitrary)++text :: String -> Layout+text s = Layout [(0, s)]++nest :: Int -> Layout -> Layout+nest k (Layout l) = Layout [(i+k, s) | (i, s) <- l]++($$) :: Layout -> Layout -> Layout+Layout xs $$ Layout ys = Layout (xs ++ ys)++(<>) :: Layout -> Layout -> Layout+Layout xs <> Layout ys =+  combine (init xs) (last xs) (head ys) (tail ys)+  where+    combine xs (i, s) (j, t) ys =+      Layout xs $$+      Layout [(i, s ++ t)] $$+      nest (i + length s - j) (Layout ys)++nesting :: Layout -> Int+nesting (Layout ((i,_):_)) = i++main = quickSpec [+  withMaxTermSize 9,+  monoType (Proxy :: Proxy Layout),+  background [+    con "\"\"" "",+    con "++" ((++) :: String -> String -> String),+    con "0" (0 :: Int),+    con "+" ((+) :: Int -> Int -> Int),+    con "length" (length :: String -> Int) ],+  series [sig1, sig2]]+  where+    sig1 = [+      con "text" text,+      con "nest" nest,+      con "$$" ($$),+      con "<>" (<>) ]+    sig2 = [con "nesting" nesting]
+ examples/Regex.hs view
@@ -0,0 +1,123 @@+-- Regular expressions.+{-# LANGUAGE GeneralizedNewtypeDeriving,DeriveDataTypeable, FlexibleInstances #-}+import qualified Control.Monad.State as S+import Control.Monad.State hiding (State, state)+import qualified Data.Map as M+import Data.List+import Data.Map(Map)+import Data.Typeable+import QuickSpec+import Test.QuickCheck+import Test.QuickCheck.Random+import Test.QuickCheck.Gen+import Data.Ord+import Data.Monoid++data Sym = A | B deriving (Eq, Ord, Typeable)++instance Arbitrary Sym where+  arbitrary = elements [A, B]++newtype State = State Int deriving (Eq, Ord, Num, Show)++data NFA a = NFA {+    epsilons :: Map State [State],+    transitions :: Map (State, Maybe a) [State],+    initial :: State,+    final :: State } deriving Show++data Regex a = Char a | AnyChar | Epsilon | Zero+             | Concat (Regex a) (Regex a)+             | Choice (Regex a) (Regex a)+             | Plus (Regex a) deriving (Typeable, Show)++-- This should really use observational equality instead.+vals :: [[Sym]]+vals = unGen (vector 100) (mkQCGen 12345) 10++instance Eq (Regex Sym) where x == y = x `compare` y == EQ+instance Ord (Regex Sym) where+  compare = comparing (\r -> map (run (compile r)) vals)++instance Arbitrary (Regex Sym) where+  arbitrary = sized arb+    where arb 0 = oneof [fmap Char arbitrary, return AnyChar, return Epsilon, return Zero]+          arb n = oneof [fmap Char arbitrary, return AnyChar, return Epsilon, return Zero,+                         liftM2 Concat arb' arb', liftM2 Choice arb' arb', fmap Plus (arb (n-1))]+            where arb' = arb (n `div` 2)++star r = Choice Epsilon (Plus r)++type M a = S.State ([(State, Maybe a, State)], [(State, State)], State)++edge :: State -> Maybe a -> State -> M a ()+edge start e end = modify (\(edges, epsilons, next) -> ((start, e, end):edges, epsilons, next))++epsilon :: State -> State -> M a ()+epsilon start end = modify (\(edges, epsilons, next) -> (edges, (start, end):epsilons, next))++state :: M a State+state = do+  (edges, epsilons, next) <- get+  put (edges, epsilons, next+1)+  return next++compile1 :: Regex a -> State -> State -> M a ()+compile1 (Char c) start end = edge start (Just c) end+compile1 AnyChar start end = edge start Nothing end+compile1 Zero start end = return ()+compile1 Epsilon start end = epsilon start end+compile1 (Concat r s) start end = do+  mid <- state+  compile1 r start mid+  compile1 s mid end+compile1 (Choice r s) start end = do+  compile1 r start end+  compile1 s start end+compile1 (Plus r) start end = do+  start' <- state+  end' <- state+  epsilon start start'+  epsilon end' end+  epsilon end' start'+  compile1 r start' end'++compile :: Ord a => Regex a -> NFA a+compile r = NFA (close (foldr enter M.empty epsilons)) (foldr flatten M.empty edges) (State 0) (State 1)+  where (edges, epsilons, _) = execState (compile1 r (State 0) (State 1)) ([], [], State 2)+        flatten (start, edge, to) edges = M.insertWith (++) (start, edge) [to] edges+        enter (from, to) epsilons = M.insertWith (++) from [to] epsilons++close :: Ord a => Map a [a] -> Map a [a]+close m | xs == [] = m+        | otherwise = close (foldr enter m xs)+        where enter (from, to) epsilons = M.insertWith (++) from [to] epsilons+              xs = nub' (close1 m)++close1 m = do+  (from, tos) <- M.toList m+  to <- tos+  to' <- M.findWithDefault [] to m+  guard (to' `notElem` tos && to' /= to && to' /= from)+  return (from, to')++run :: Ord a => NFA a -> [a] -> Bool+run nfa = runFrom nfa [initial nfa]+runFrom nfa states = runFrom' nfa (nub' (concatMap (epsilonClosed nfa) states))+runFrom' nfa states [] = final nfa `elem` states+runFrom' nfa states (x:xs) = runFrom nfa (nub' $ concat [ M.findWithDefault [] (s, Just x) (transitions nfa) ++ M.findWithDefault [] (s, Nothing) (transitions nfa) | s <- states ]) xs+epsilonClosed nfa s = s:M.findWithDefault [] s (epsilons nfa)++nub' :: Ord a => [a] -> [a]+nub' = map head . group . sort++main = quickSpec [+  con "char" (Char :: Sym -> Regex Sym),+  con "any" (AnyChar :: Regex Sym),+  con "e" (Epsilon :: Regex Sym),+  con "0" (Zero :: Regex Sym),+  con ";" (Concat :: Regex Sym -> Regex Sym -> Regex Sym),+  con "|" (Choice :: Regex Sym -> Regex Sym -> Regex Sym),+  con "*" (star :: Regex Sym -> Regex Sym),+  monoType (Proxy :: Proxy (Regex Sym)),+  monoType (Proxy :: Proxy Sym) ]
+ examples/Sorted.hs view
@@ -0,0 +1,15 @@+-- Sorting and sorted lists.+-- Illustrates testing of conditional laws.+import QuickSpec+import Data.List++sorted :: Ord a => [a] -> Bool+sorted [] = True+sorted [_] = True+sorted (x:y:xs) = x <= y && sorted (y:xs)++main = quickSpec [+  lists `without` ["++"],+  con "sort" (sort :: [Int] -> [Int]),+  con "insert" (insert :: Int -> [Int] -> [Int]),+  predicate "sorted" (sorted :: [Int] -> Bool) ]
− examples/TinyWM.hs 
@@ -1,189 +0,0 @@--- A window manager example,--- taken from http://donsbot.wordpress.com/2007/05/01/roll-your-own-window-manager-part-1-defining-and-testing-a-model--{-# OPTIONS -fglasgow-exts #-}--import Data.Maybe-import Data.Map (Map)-import Data.Typeable-import qualified Data.Map as M-import qualified Data.List as L-import Test.QuickCheck-import Test.QuickSpec---- ------------------------------------------------------------------------ A data structure for multiple workspaces containing stacks of screens-----data StackSet a = StackSet-    { current :: Int           -- the current workspace-    , stacks  :: Map Int [a] } -- map workspaces to window stacks-    deriving (Eq, Ord, Show, Read, Typeable)---- | /O(n)/. Create a new empty stackset of 'n' workspaces-empty :: Ord a => Int -> StackSet a-empty n = StackSet { current = 0, stacks  = ws }-  where-    ws = M.fromList (zip [0..n-1] (repeat []))---- | /O(log n)/. Set the given stack as being visible. If the index is out of--- bounds, the stack is returned unmodified.-view :: Int -> StackSet a -> StackSet a-view n w | M.member n (stacks w) = w { current = n }-         | otherwise             = w---- | /O(log s)/. Extract the element on the top of the current stack.--- If no such element exists, Nothing is returned.-peek :: Ord a => StackSet a -> Maybe a-peek w | Just (x:_) <- M.lookup (current w) (stacks w) = Just x-       | otherwise                                     = Nothing---- | /O(log n)/. rotate. cycle the current window list up or down.--- Has the effect of rotating focus. In fullscreen mode this will cause--- a new window to be visible.------  rotate EQ   -->  [5,6,7,8,1,2,3,4]---  rotate GT   -->  [6,7,8,1,2,3,4,5]---  rotate LT   -->  [4,5,6,7,8,1,2,3]------  where xs = [5..8] ++ [1..4]----rotate :: Ordering -> StackSet a -> StackSet a-rotate o w = w { stacks = M.adjust rot (current w) (stacks w) }-  where-    rot [] = []-    rot xs = case o of-        GT -> tail xs ++ [head xs]-        LT -> last xs : init xs-        _  -> xs---- ------------------------------------------------------------------------ operations that affect multiple workspaces---- | /O(log n)/. Push. Insert an element onto the top of the current stack.--- If the element is already in the current stack, it is moved to the top.--- If the element is managed on another stack, it is removed from that stack.----push :: Ord a => a -> StackSet a -> StackSet a-push k w = insert k (current w) w---- | /O(log n)/. shift. move the client on top of the current stack to--- the top of stack 'n'. If the stack to move to is not valid, and--- exception is thrown. If there's no client on the current stack, the--- stack set is returned unchanged.-shift :: (Ord a) => Int -> StackSet a -> StackSet a-shift n w = maybe w (\k -> insert k n w) (peek w)---- | /O(log n)/. Insert an element onto the top of stack 'n'.--- If the element is already in the stack 'n', it is moved to the top.--- If the element exists on another stack, it is removed from that stack.--- If the index is wrong an exception is thrown.-insert :: Ord a => a -> Int -> StackSet a -> StackSet a-insert k n old = new { stacks = M.adjust (k:) n (stacks new) }-    where new = delete k old---- | /O(n)/. Delete an element entirely from from the StackSet.--- If the element doesn't exist, the original StackSet is returned unmodified.--- If the current element is focused, focus will change.-delete :: Ord a => a -> StackSet a -> StackSet a-delete k w = maybe w del $ L.find ((k `elem`) . snd) (M.assocs (stacks w))-  where-    del (i,_) = w { stacks = M.adjust (L.delete k) i (stacks w) }---- | /O(log n)/. Index. Extract the stack at workspace 'n'.--- If the index is invalid, an exception is thrown.-index :: Int -> StackSet a -> [a]-index k w = fromJust (M.lookup k (stacks w))------- Arbitrary instances and helper functions.----------------------------------------------------------------------------------- Building StackSets from lists-----fromList :: Ord a => (Int, [[a]]) -> StackSet a-fromList (_,[]) = error "Cannot build a StackSet from an empty list"-fromList (n,xs) | n < 0 || n >= length xs-                = error $ "Cursor index is out of range: " ++ show (n, length xs)-fromList (o,xs) = view o $-    foldr (\(i,ys) s ->-        foldr (\a t -> insert a i t) s ys)-            (empty (length xs)) (zip [0..] xs)---- flatten a stackset to a list-toList  :: StackSet a -> (Int,[[a]])-toList x = (current x, map snd $ M.toList (stacks x))---- --------------------------------------------------------------------------- Some useful predicates and helpers------- a window is a member-member :: Ord a => a -> StackSet a -> Bool-member k w =-    case L.find ((k `elem`) . snd) (M.assocs (stacks w)) of-        Nothing -> False-        _       -> True---- | /O(n)/. Number of stacks-size :: T -> Int-size = M.size . stacks---- | Height of stack 'n'-height :: Int -> T -> Int-height i w = length (index i w)------- Generate arbitrary stacksets----instance (Ord a, Arbitrary a) => Arbitrary (StackSet a) where-    arbitrary = do-        sz <- choose (1,5)-        n  <- choose (0,sz-1)-        ls <- vector sz-        let s = fromList (fromIntegral n,ls)-        return s--instance (Ord a, CoArbitrary a) => CoArbitrary (StackSet a) where-    coarbitrary s = coarbitrary (toList s)------- QuickSpec stuff.-----ordering :: Sig-ordering = signature [-  con "LT" LT,-  con "GT" GT,-  con "EQ" EQ,-  vars ["o", "o'"] (undefined :: Ordering)]------- constrain it to a simple element type----type T = StackSet A--tinywm :: [Sig]-tinywm = [-  prelude (undefined :: A) `without` ["+", "*"],-  gvars ["x", "y", "q"] (choose (0, 3) :: Gen Int),-  ordering,--  ["s"] `vars` (undefined :: T),--  "empty"   `fun1` (empty           :: Int -> T),-  "view"    `fun2` (view            :: Int -> T -> T),-  "peek"    `fun1` (fromJust . peek :: T -> A),-  "rotate"  `fun2` (rotate          :: Ordering -> T -> T),-  "push"    `fun2` (push            :: A -> T -> T),-  "shift"   `fun2` (shift           :: Int -> T -> T),-  "insert"  `fun3` (insert          :: A -> Int -> T -> T),-  "delete"  `fun2` (delete          :: A -> T -> T),-  "current" `fun1` (current         :: T -> Int),-  "index"   `fun2` (index           :: Int -> T -> [A])]--main = quickSpec tinywm
+ examples/Zip.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TypeApplications #-}+-- A test for conditions.+-- Many laws for zip only hold when the arguments have the same+-- length.+import QuickSpec++eqLen :: [a] -> [b] -> Bool+eqLen xs ys = length xs == length ys++main = quickSpec [+  -- Explore bigger terms.+  withMaxTermSize 8,+  con "++" ((++) @Int),+  con "zip" (zip @Int @Int),+  predicate "eqLen" (eqLen @Int @Int) ]
quickspec.cabal view
@@ -1,6 +1,6 @@ Name:                quickspec-Version:             0.9.6-Cabal-version:       >= 1.6+Version:             2.2+Cabal-version:       >= 1.10 Build-type:          Simple  Homepage:            https://github.com/nick8325/quickspec@@ -9,43 +9,61 @@  License:             BSD3 License-file:        LICENSE-Copyright:           2009-2013 Nick Smallbone+Copyright:           2009-2019 Nick Smallbone  Category:            Testing  Synopsis:            Equational laws for free! Description:-  QuickSpec automatically finds equational laws about your program.+  QuickSpec takes your Haskell code and, as if by magic, discovers laws+  about it. You give QuickSpec a collection of Haskell functions;+  QuickSpec tests your functions with QuickCheck and prints out laws which+  seem to hold.   .-  Give it an API, i.e. a collection of functions, and it will spit out-  equations about those functions. For example, given @reverse@, @++@-  and @[]@, QuickSpec finds six laws, which are exactly the ones you-  might write by hand:+  For example, give QuickSpec the functions @reverse@, @++@ and @[]@, and+  it will find six laws:   .-  > xs++[] == xs-  > []++xs == xs-  > (xs++ys)++zs == xs++(ys++zs)   > reverse [] == []+  > xs ++ [] == xs+  > [] ++ xs == xs   > reverse (reverse xs) == xs-  > reverse xs++reverse ys == reverse (ys++xs)+  > (xs ++ ys) ++ zs == xs ++ (ys ++ zs)+  > reverse xs ++ reverse ys == reverse (ys ++ xs)   .-  The laws that QuickSpec generates are not proved correct, but have-  passed at least 200 QuickCheck tests.+  QuickSpec can find equational laws as well as conditional equations. All+  you need to supply are the functions to test, as well as @Ord@ and+  @Arbitrary@ instances for QuickSpec to use in testing; the rest is+  automatic.   .-  For more information, see the @README@ file at-  https://github.com/nick8325/quickspec/blob/master/README.asciidoc.+  For information on how to use QuickSpec, see the documentation in the main+  module, "QuickSpec". You can also look in the+  @<https://github.com/nick8325/quickspec/tree/master/examples examples>@+  directory, for example at+  @<https://github.com/nick8325/quickspec/tree/master/examples/Lists.hs Lists.hs>@,+  @<https://github.com/nick8325/quickspec/tree/master/examples/IntSet.hs IntSet.hs>@, or+  @<https://github.com/nick8325/quickspec/tree/master/examples/Parsing.hs Parsing.hs>@.+  To read about how+  QuickSpec works, see our paper,+  <http://www.cse.chalmers.se/~nicsma/papers/quickspec2.pdf Quick specifications for the busy programmer>.  Extra-source-files:-  README.asciidoc+  README.md   examples/Arith.hs-  examples/Arrays.hs   examples/Bools.hs   examples/Composition.hs-  examples/Heaps.hs+  examples/Curry.hs+  examples/Geometry.hs+  examples/HugeLists.hs+  examples/IntSet.hs+  examples/ListMonad.hs   examples/Lists.hs+  examples/Octonions.hs+  examples/Parsing.hs   examples/PrettyPrinting.hs-  examples/TinyWM.hs-  src/Test/QuickSpec/errors.h+  examples/PrettyPrintingModel.hs+  examples/Regex.hs+  examples/Sorted.hs+  examples/Zip.hs  source-repository head   type:     git@@ -53,32 +71,46 @@   branch:   master  library+  default-language: Haskell2010+  ghc-options: -W   hs-source-dirs: src-  include-dirs: src/Test/QuickSpec/   Exposed-modules:-    Test.QuickSpec,-    Test.QuickSpec.Main,-    Test.QuickSpec.Signature,-    Test.QuickSpec.Prelude,-    Test.QuickSpec.Term,-    Test.QuickSpec.Equation,-    Test.QuickSpec.Generate,-    Test.QuickSpec.TestTree,-    Test.QuickSpec.Reasoning.UnionFind,-    Test.QuickSpec.Reasoning.CongruenceClosure,-    Test.QuickSpec.Reasoning.NaiveEquationalReasoning,-    Test.QuickSpec.Reasoning.PartialEquationalReasoning,-    Test.QuickSpec.TestTotality,-    Test.QuickSpec.Utils,-    Test.QuickSpec.Utils.Typeable,-    Test.QuickSpec.Utils.Typed,-    Test.QuickSpec.Utils.TypeMap,-    Test.QuickSpec.Utils.TypeRel,-    Test.QuickSpec.Approximate-  Other-modules:-    -- Dangerous!-    Test.QuickSpec.Utils.MemoValuation+    QuickSpec+    QuickSpec.Internal+    QuickSpec.Internal.Explore+    QuickSpec.Internal.Explore.Conditionals+    QuickSpec.Internal.Explore.Polymorphic+    QuickSpec.Internal.Explore.Schemas+    QuickSpec.Internal.Explore.Terms+    QuickSpec.Internal.Haskell+    QuickSpec.Internal.Haskell.Resolve+    QuickSpec.Internal.Parse+    QuickSpec.Internal.Prop+    QuickSpec.Internal.Pruning+    QuickSpec.Internal.Pruning.Background+    QuickSpec.Internal.Pruning.Twee+    QuickSpec.Internal.Pruning.Types+    QuickSpec.Internal.Pruning.UntypedTwee+    QuickSpec.Internal.Pruning.PartialApplication+    QuickSpec.Internal.Term+    QuickSpec.Internal.Terminal+    QuickSpec.Internal.Testing+    QuickSpec.Internal.Testing.DecisionTree+    QuickSpec.Internal.Testing.QuickCheck+    QuickSpec.Internal.Type+    QuickSpec.Internal.Utils    Build-depends:-    base < 5, containers, transformers, QuickCheck >= 2.7,-    random, spoon >= 0.2, array, ghc-prim+    QuickCheck >= 2.14.2,+    quickcheck-instances >= 0.3.16,+    base >= 4.7 && < 5,+    constraints,+    containers,+    data-lens-light >= 0.1.1,+    dlist,+    random,+    spoon,+    template-haskell,+    transformers,+    twee-lib,+    uglymemo
+ src/QuickSpec.hs view
@@ -0,0 +1,114 @@+-- | The main QuickSpec module. Everything you need to run QuickSpec lives here.+--+-- To run QuickSpec, you need to tell it which functions to test. We call the+-- list of functions the /signature/. Here is an example signature, which tells+-- QuickSpec to test the @++@, @reverse@ and @[]@ functions:+--+-- @+-- sig = [+--   `con` "++"      ((++) :: [`A`] -> [`A`] -> [`A`]),+--   `con` "reverse" (reverse :: [`A`] -> [`A`]),+--   `con` "[]"      ([] :: [`A`]) ]+-- @+--+-- The `con` function, used above, adds a function to the signature, given its+-- name and its value. When declaring polymorphic functions in the signature,+-- we use the types `A` to `E` to represent type variables.+-- Having defined this signature, we can say @`quickSpec` sig@ to test it and+-- see the discovered equations.+--+-- If you want to test functions over your own datatypes, those types need to+-- implement `Arbitrary` and `Ord` (if the `Ord` instance is a problem, see `Observe`).+-- You must also declare those instances to QuickSpec, by including them in the+-- signature. For monomorphic types you can do this using `monoType`:+--+-- @+-- data T = ...+-- main = quickSpec [+--   ...,+--   `monoType` (Proxy :: Proxy T)]+-- @+--+-- You can only declare monomorphic types with `monoType`. If you want to test+-- your own polymorphic types, you must explicitly declare `Arbitrary` and `Ord`+-- instances using the `inst` function. You can also use the `generator` function+-- to use a custom generator instead of the `Arbitrary` instance for a given type.+--+-- You can also use QuickSpec to find conditional equations. To do so, you need+-- to include some /predicates/ in the signature. These are functions returning+-- `Bool` which can appear as conditions in other equations. Declaring a predicate+-- works just like declaring a function, except that you declare it using+-- `predicate` instead of `con`.+--+-- You can also put certain options in the signature. The most useful is+-- `withMaxTermSize', which you can use to tell QuickSpec to generate larger+-- equations.+--+-- The @<https://github.com/nick8325/quickspec/tree/master/examples examples>@+-- directory contains many examples. Here are some interesting ones:+--+-- * @<https://github.com/nick8325/quickspec/tree/master/examples/Arith.hs Arith.hs>@: a simple arithmetic example. Demonstrates basic use of QuickSpec.+-- * @<https://github.com/nick8325/quickspec/tree/master/examples/Lists.hs Lists.hs>@: list functions. Demonstrates testing polymorphic functions.+-- * @<https://github.com/nick8325/quickspec/tree/master/examples/Sorted.hs Sorted.hs>@: sorting. Demonstrates finding conditional equations.+-- * @<https://github.com/nick8325/quickspec/tree/master/examples/IntSet.hs IntSet.hs>@: a few functions from "Data.IntSet". Demonstrates testing user-defined datatypes and finding conditional equations.+-- * @<https://github.com/nick8325/quickspec/tree/master/examples/PrettyPrinting.hs PrettyPrinting.hs>@: pretty printing combinators. Demonstrates testing user-defined datatypes and using observational equality.+-- * @<https://github.com/nick8325/quickspec/tree/master/examples/Parsing.hs Parsing.hs>@: parser combinators. Demonstrates testing polymorphic datatypes and using observational equality.+--+-- You can also find some larger case studies in our paper,+-- <http://www.cse.chalmers.se/~nicsma/papers/quickspec2.pdf Quick specifications for the busy programmer>.++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+module QuickSpec(+  -- * Running QuickSpec+  quickSpec, Sig, Signature(..),++  -- * Declaring functions and predicates+  con, predicate, predicateGen,+  -- ** Type variables for polymorphic functions+  A, B, C, D, E,++  -- * Declaring types+  monoType, monoTypeObserve, Observe(..), inst, generator,+  vars, monoTypeWithVars, monoTypeObserveWithVars,+  variableUse, VariableUse(..),+  +  -- * Declaring types: @TypeApplication@-friendly variants+  mono, monoObserve, monoVars, monoObserveVars,++  -- * Standard signatures+  -- | The \"prelude\": a standard signature containing useful functions+  --   like '++', which can be used as background theory.+  lists, arith, funs, bools, prelude, without,++  -- * Exploring functions in series+  background, series,++  -- * Including type class constraints (experimental, subject to change)+  type (==>), liftC, instanceOf,++  -- * Customising QuickSpec+  withMaxTermSize, withMaxTests, withMaxTestSize, withMaxFunctions, defaultTo,+  withPruningDepth, withPruningTermSize, withFixedSeed,+  withInferInstanceTypes, withPrintStyle, PrintStyle(..),+  withConsistencyCheck,++  -- * Integrating with QuickCheck+  (=~=),++  -- * Re-exported functionality+  Typeable, (:-)(..), Dict(..), Proxy(..), Arbitrary) where++import QuickSpec.Internal+import QuickSpec.Internal.Haskell(Observe(..), PrintStyle(..), (=~=))+import QuickSpec.Internal.Type(A, B, C, D, E)+import QuickSpec.Internal.Explore.Schemas(VariableUse(..))+import Data.Typeable+import Data.Constraint+import Test.QuickCheck
+ src/QuickSpec/Internal.hs view
@@ -0,0 +1,462 @@+-- | The main QuickSpec module, with internal stuff exported.+-- For QuickSpec hackers only.+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}+module QuickSpec.Internal where++import QuickSpec.Internal.Haskell(Predicateable, PredicateTestCase, Names(..), Observe(..), Use(..), HasFriendly, FriendlyPredicateTestCase)+import qualified QuickSpec.Internal.Haskell as Haskell+import qualified QuickSpec.Internal.Haskell.Resolve as Haskell+import qualified QuickSpec.Internal.Testing.QuickCheck as QuickCheck+import qualified QuickSpec.Internal.Pruning.UntypedTwee as Twee+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Term(Term)+import QuickSpec.Internal.Explore.Schemas(VariableUse(..))+import Test.QuickCheck+import Test.QuickCheck.Random+import Data.Constraint+import Data.Lens.Light+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Type hiding (defaultTo)+import Data.Proxy+import System.Environment+#if !MIN_VERSION_base(4,9,0)+import Data.Semigroup(Semigroup(..))+#endif++-- | Run QuickSpec. See the documentation at the top of this file.+quickSpec :: Signature sig => sig -> IO ()+quickSpec sig = do+  quickSpecResult sig+  return ()++-- | Run QuickSpec, returning the list of discovered properties.+quickSpecResult :: Signature sig => sig -> IO [Prop (Term Haskell.Constant)]+quickSpecResult sig = do+  -- Undocumented feature for testing :)+  seed <- lookupEnv "QUICKCHECK_SEED"+  let+    sig' = case seed of+      Nothing -> signature sig+      Just xs -> signature [signature sig, withFixedSeed (read xs)]++  Haskell.quickSpec (runSig sig' (Context 1 []) Haskell.defaultConfig)++-- | Add some properties to the background theory.+addBackground :: [Prop (Term Haskell.Constant)] -> Sig+addBackground props =+  Sig $ \_ cfg -> cfg { Haskell.cfg_background = Haskell.cfg_background cfg ++ props }++-- | A signature.+newtype Sig = Sig { unSig :: Context -> Haskell.Config -> Haskell.Config }++-- Settings for building the signature.+-- Int: number of nested calls to 'background'.+-- [String]: list of names to exclude.+data Context = Context Int [String]++instance Semigroup Sig where+  Sig sig1 <> Sig sig2 = Sig (\ctx -> sig2 ctx . sig1 ctx)+instance Monoid Sig where+  mempty = Sig (\_ -> id)+  mappend = (<>)++-- | A class of things that can be used as a QuickSpec signature.+class Signature sig where+  -- | Convert the thing to a signature.+  signature :: sig -> Sig++instance Signature Sig where+  signature = id++instance Signature sig => Signature [sig] where+  signature = mconcat . map signature++runSig :: Signature sig => sig -> Context -> Haskell.Config -> Haskell.Config+runSig = unSig . signature++-- | Declare a constant with a given name and value.+-- If the constant you want to use is polymorphic, you can use the types+-- `A`, `B`, `C`, `D`, `E` to monomorphise it, for example:+--+-- > constant "reverse" (reverse :: [A] -> [A])+--+-- QuickSpec will then understand that the constant is really polymorphic.+con :: Typeable a => String -> a -> Sig+con name x =+  Sig $ \ctx@(Context _ names) ->+    if name `elem` names then id else+      unSig (customConstant (Haskell.con name x)) ctx++-- | Add a custom constant.+customConstant :: Haskell.Constant -> Sig+customConstant con =+  Sig $ \(Context n _) ->+    modL Haskell.lens_constants (appendAt n [con])++-- | Type class constraints as first class citizens+type c ==> t = Dict c -> t++-- | Lift a constrained type to a `==>` type which QuickSpec+-- can work with+liftC :: (c => a) -> c ==> a+liftC a Dict = a++-- | Add an instance of a type class to the signature+instanceOf :: forall c. (Typeable c, c) => Sig+instanceOf = inst (Sub Dict :: () :- c)++-- | Declare a predicate with a given name and value.+-- The predicate should be a function which returns `Bool`.+-- It will appear in equations just like any other constant,+-- but will also be allowed to appear as a condition.+--+-- Warning: if the predicate is unlikely to be true for a+-- randomly-generated value, you will get bad-quality test data.+-- In that case, use `predicateGen` instead.+--+-- For example:+--+-- @+-- sig = [+--   `con` "delete" (`Data.List.delete` :: Int -> [Int] -> [Int]),+--   `con` "insert" (`Data.List.insert` :: Int -> [Int] -> [Int]),+--   predicate "member" (member :: Int -> [Int] -> Bool) ]+-- @+predicate :: ( Predicateable a+             , Haskell.PredicateResult a ~ Bool+             , Typeable a+             , Typeable (PredicateTestCase a))+             => String -> a -> Sig+predicate name x =+  Sig $ \ctx@(Context _ names) ->+    if name `elem` names then id else+    let (insts, con) = Haskell.predicate name x in+      runSig [addInstances insts `mappend` customConstant con] ctx++-- | Declare a predicate with a given name and value.+-- The predicate should be a function which returns `Bool`.+-- It will appear in equations just like any other constant,+-- but will also be allowed to appear as a condition.+-- The third argument is a generator for values satisfying the predicate.+--+-- For example, this declares a predicate that checks if a list is+-- sorted:+--+-- > predicateGen "sorted" sorted genSortedList+--+-- where+--+-- > sorted :: [a] -> Bool+-- > sorted xs = sort xs == xs+-- > genSortedList :: Gen [a]+-- > genSortedList = sort <$> arbitrary+predicateGen :: ( Predicateable a+                , Typeable a+                , Typeable (PredicateTestCase a)+                , HasFriendly (PredicateTestCase a))+                => String -> a -> Gen (FriendlyPredicateTestCase a) -> Sig+predicateGen name x gen =+  Sig $ \ctx@(Context _ names) ->+    if name `elem` names then id else+    let (insts, con) = Haskell.predicateGen name x gen in+      runSig [addInstances insts `mappend` customConstant con] ctx++-- | Declare a new monomorphic type.+-- The type must implement `Ord` and `Arbitrary`.+--+-- If the type does not implement `Ord`, you can use `monoTypeObserve`+-- to declare an observational equivalence function. If the type does+-- not implement `Arbitrary`, you can use `generator` to declare a+-- custom QuickCheck generator.+--+-- You do not necessarily need `Ord` and `Arbitrary` instances for+-- every type. If there is no `Ord` (or `Observe` instance) for a+-- type, you will not get equations between terms of that type. If+-- there is no `Arbitrary` instance (or generator), you will not get+-- variables of that type.+monoType :: forall proxy a. (Ord a, Arbitrary a, Typeable a) => proxy a -> Sig+monoType _ =+  mconcat [+    inst (Sub Dict :: () :- Ord a),+    inst (Sub Dict :: () :- Arbitrary a)]++-- | Like 'monoType', but designed to be used with TypeApplications directly.+--+-- For example, you can add 'Foo' to your signature via:+--+-- @+-- `mono` @Foo+-- @+mono :: forall a. (Ord a, Arbitrary a, Typeable a) => Sig+mono = monoType (Proxy @a)++-- | Declare a new monomorphic type using observational equivalence.+-- The type must implement `Observe` and `Arbitrary`.+monoTypeObserve :: forall proxy test outcome a.+  (Observe test outcome a, Arbitrary test, Ord outcome, Arbitrary a, Typeable test, Typeable outcome, Typeable a) =>+  proxy a -> Sig+monoTypeObserve _ =+  mconcat [+    inst (Sub Dict :: () :- Observe test outcome a),+    inst (Sub Dict :: () :- Arbitrary a)]++-- | Like 'monoTypeObserve', but designed to be used with TypeApplications directly.+--+-- For example, you can add 'Foo' to your signature via:+--+-- @+-- `monoObserve` @Foo+-- @+monoObserve :: forall a test outcome.+  (Observe test outcome a, Arbitrary test, Ord outcome, Arbitrary a, Typeable test, Typeable outcome, Typeable a) =>+  Sig+monoObserve = monoTypeObserve (Proxy @a)++-- | Declare a new monomorphic type using observational equivalence, saying how you want variables of that type to be named.+monoTypeObserveWithVars :: forall proxy test outcome a.+  (Observe test outcome a, Arbitrary test, Ord outcome, Arbitrary a, Typeable test, Typeable outcome, Typeable a) =>+  [String] -> proxy a -> Sig+monoTypeObserveWithVars xs proxy =+  monoTypeObserve proxy `mappend` vars xs proxy++-- | Like 'monoTypeObserveWithVars', but designed to be used with TypeApplications directly.+--+-- For example, you can add 'Foo' to your signature via:+--+-- @+-- `monoObserveVars` @Foo ["foo"]+-- @+monoObserveVars :: forall a test outcome.+  (Observe test outcome a, Arbitrary test, Ord outcome, Arbitrary a, Typeable test, Typeable outcome, Typeable a) =>+  [String] -> Sig+monoObserveVars xs = monoTypeObserveWithVars xs (Proxy @a)++-- | Declare a new monomorphic type, saying how you want variables of that type to be named.+monoTypeWithVars :: forall proxy a. (Ord a, Arbitrary a, Typeable a) => [String] -> proxy a -> Sig+monoTypeWithVars xs proxy =+  monoType proxy `mappend` vars xs proxy++-- | Like 'monoTypeWithVars' designed to be used with TypeApplications directly.+--+-- For example, you can add 'Foo' to your signature via:+--+-- @+-- `monoVars` @Foo ["foo"]+-- @+monoVars :: forall a. (Ord a, Arbitrary a, Typeable a) => [String] -> Sig+monoVars xs = monoTypeWithVars xs (Proxy @a)++-- | Customize how variables of a particular type are named.+vars :: forall proxy a. Typeable a => [String] -> proxy a -> Sig+vars xs _ = instFun (Names xs :: Names a)++-- | Constrain how variables of a particular type may occur in a term.+-- The default value is @'UpTo' 4@.+variableUse :: forall proxy a. Typeable a => VariableUse -> proxy a -> Sig+variableUse x _ = instFun (Use x :: Use a)++-- | Declare a typeclass instance. QuickSpec needs to have an `Ord` and+-- `Arbitrary` instance for each type you want it to test.+--+-- For example, if you are testing @`Data.Map.Map` k v@, you will need to add+-- the following two declarations to your signature:+--+-- @+-- `inst` (`Sub` `Dict` :: (Ord A, Ord B) `:-` Ord (Map A B))+-- `inst` (`Sub` `Dict` :: (Arbitrary A, Arbitrary B) `:-` Arbitrary (Map A B))+-- @+--+-- For a monomorphic type @T@, you can use `monoType` instead, but if you+-- want to use `inst`, you can do it like this:+--+-- @+-- `inst` (`Sub` `Dict` :: () `:-` Ord T)+-- `inst` (`Sub` `Dict` :: () `:-` Arbitrary T)+-- @+inst :: (Typeable c1, Typeable c2) => c1 :- c2 -> Sig+inst = instFun++-- | Declare a generator to be used to produce random values of a+-- given type. This will take precedence over any `Arbitrary` instance.+generator :: Typeable a => Gen a -> Sig+generator = instFun++-- | Declare an arbitrary value to be used by instance resolution.+instFun :: Typeable a => a -> Sig+instFun x = addInstances (Haskell.inst x)++addInstances :: Haskell.Instances -> Sig+addInstances insts =+  Sig (\_ -> modL Haskell.lens_instances (`mappend` insts))++withPrintFilter :: (Prop (Term Haskell.Constant) -> Bool) -> Sig+withPrintFilter p =+  Sig (\_ -> setL Haskell.lens_print_filter p)++-- | Declare some functions as being background functions.+-- These are functions which are not interesting on their own,+-- but which may appear in interesting laws with non-background functions.+-- Declaring background functions may improve the laws you get out.+--+-- Here is an example, which tests @++@ and @length@, giving @0@ and @+@ as+-- background functions:+--+-- > main = quickSpec [+-- >   con "++" ((++) :: [A] -> [A] -> [A]),+-- >   con "length" (length :: [A] -> Int),+-- >+-- >   background [+-- >     con "0" (0 :: Int),+-- >     con "+" ((+) :: Int -> Int -> Int) ] ]+background :: Signature sig => sig -> Sig+background sig =+  Sig (\(Context _ xs) -> runSig sig (Context 0 xs))++-- | Remove a function or predicate from the signature.+-- Useful in combination with 'prelude' and friends.+without :: Signature sig => sig -> [String] -> Sig+without sig xs =+  Sig (\(Context n ys) -> runSig sig (Context n (ys ++ xs)))++-- | Run QuickCheck on a series of signatures. Tests the functions in the first+-- signature, then adds the functions in the second signature, then adds the+-- functions in the third signature, and so on.+--+-- This can be useful when you have a core API you want to test first, and a+-- larger API you want to test later. The laws for the core API will be printed+-- separately from the laws for the larger API.+--+-- Here is an example which first tests @0@ and @+@ and then adds @++@ and @length@:+--+-- > main = quickSpec (series [sig1, sig2])+-- >   where+-- >     sig1 = [+-- >       con "0" (0 :: Int),+-- >       con "+" ((+) :: Int -> Int -> Int) ]+-- >     sig2 = [+-- >       con "++" ((++) :: [A] -> [A] -> [A]),+-- >       con "length" (length :: [A] -> Int) ]+series :: Signature sig => [sig] -> Sig+series = foldr op mempty . map signature+  where+    op sig sigs = sig `mappend` later (signature sigs)+    later sig =+      Sig (\(Context n xs) cfg -> unSig sig (Context (n+1) xs) cfg)++-- | Set the maximum size of terms to explore (default: 7).+withMaxTermSize :: Int -> Sig+withMaxTermSize n = Sig (\_ -> setL Haskell.lens_max_size n)++withMaxCommutativeSize :: Int -> Sig+withMaxCommutativeSize n = Sig (\_ -> setL Haskell.lens_max_commutative_size n)++-- | Limit how many different function symbols can occur in a term.+withMaxFunctions :: Int -> Sig+withMaxFunctions n = Sig (\_ -> setL Haskell.lens_max_functions n)++-- | Set how many times to test each discovered law (default: 1000).+withMaxTests :: Int -> Sig+withMaxTests n =+  Sig (\_ -> setL (QuickCheck.lens_num_tests # Haskell.lens_quickCheck) n)++-- | Set the maximum value for QuickCheck's size parameter when generating test+-- data (default: 20).+withMaxTestSize :: Int -> Sig+withMaxTestSize n =+  Sig (\_ -> setL (QuickCheck.lens_max_test_size # Haskell.lens_quickCheck) n)++-- | Set which type polymorphic terms are tested at.+defaultTo :: Typeable a => proxy a -> Sig+defaultTo proxy = Sig (\_ -> setL Haskell.lens_default_to (typeRep proxy))++-- | Set how QuickSpec should display its discovered equations (default: 'ForHumans').+--+-- If you'd instead like to turn QuickSpec's output into QuickCheck tests, set+-- this to 'ForQuickCheck'.+withPrintStyle :: Haskell.PrintStyle -> Sig+withPrintStyle style = Sig (\_ -> setL Haskell.lens_print_style style)++-- | Set how hard QuickSpec tries to filter out redundant equations (default: no limit).+--+-- If you experience long pauses when running QuickSpec, try setting this number+-- to 2 or 3.+withPruningDepth :: Int -> Sig+withPruningDepth n =+  Sig (\_ -> setL (Twee.lens_max_cp_depth # Haskell.lens_twee) n)++-- | Set the maximum term size QuickSpec will reason about when it filters out+-- redundant equations (default: same as maximum term size).+--+-- If you get laws you believe are redundant, try increasing this number to 1 or+-- 2 more than the maximum term size.+withPruningTermSize :: Int -> Sig+withPruningTermSize n =+  Sig (\_ -> setL (Twee.lens_max_term_size # Haskell.lens_twee) n)++-- | Set the random number seed used for test case generation.+-- Useful if you want repeatable results.+withFixedSeed :: Int -> Sig+withFixedSeed s = Sig (\_ -> setL (QuickCheck.lens_fixed_seed # Haskell.lens_quickCheck) (Just . mkQCGen $ s))++-- | Automatically infer types to add to the universe from+-- available type class instances+withInferInstanceTypes :: Sig+withInferInstanceTypes = Sig (\_ -> setL (Haskell.lens_infer_instance_types) True)++-- | (Experimental) Check that the discovered laws do not imply any+-- false laws+withConsistencyCheck :: Sig+withConsistencyCheck = Sig (\_ -> setL (Haskell.lens_check_consistency) True)++-- | A signature containing boolean functions:+-- @(`||`)@, @(`&&`)@, `not`, `True`, `False`.+bools :: Sig+bools = background [+  "||"    `con` (||),+  "&&"    `con` (&&),+  "not"   `con` not,+  "True"  `con` True,+  "False" `con` False]++-- | A signature containing arithmetic operations:+-- @0@, @1@, @(`+`)@.+-- Instantiate it with e.g. @arith (`Proxy` :: `Proxy` `Int`)@.+arith :: forall proxy a. (Typeable a, Ord a, Num a, Arbitrary a) => proxy a -> Sig+arith proxy = background [+  monoType proxy,+  "0" `con` (0   :: a),+  "1" `con` (1   :: a),+  "+" `con` ((+) :: a -> a -> a)]++-- | A signature containing list operations:+-- @[]@, @(:)@, @(`++`)@.+lists :: Sig+lists = background [+  "[]"      `con` ([]      :: [A]),+  ":"       `con` ((:)     :: A -> [A] -> [A]),+  "++"      `con` ((++)    :: [A] -> [A] -> [A])]++-- | A signature containing higher-order functions:+-- @(`.`)@ and `id`.+-- Useful for testing `map` and similar.+funs :: Sig+funs = background [+  "."  `con` ((.) :: (A -> A) -> (A -> A) -> (A -> A)),+  "id" `con` (id  :: A -> A) ]++-- | The QuickSpec prelude.+-- Contains boolean, arithmetic and list functions, and function composition.+-- For more precise control over what gets included,+-- see 'bools', 'arith', 'lists', 'funs' and 'without'.+prelude :: Sig+prelude = signature [bools, arith (Proxy :: Proxy Int), lists]
+ src/QuickSpec/Internal/Explore.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleContexts, PatternGuards, CPP #-}+module QuickSpec.Internal.Explore where++import QuickSpec.Internal.Explore.Polymorphic+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Term+import QuickSpec.Internal.Type+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Terminal+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Text.Printf+#if! MIN_VERSION_base(4,9,0)+import Data.Semigroup(Semigroup(..))+#endif+import Data.List++newtype Enumerator a = Enumerator { enumerate :: Int -> [[a]] -> [a] }++-- N.B. order matters!+-- Later enumerators get to see terms which were generated by earlier ones.+instance Semigroup (Enumerator a) where+  e1 <> e2 = Enumerator $ \n tss ->+    let us = enumerate e1 n tss+        vs = enumerate e2 n (appendAt n us tss)+    in us ++ vs+instance Monoid (Enumerator a) where+  mempty = Enumerator (\_ _ -> [])+  mappend = (<>)++mapEnumerator :: ([a] -> [a]) -> Enumerator a -> Enumerator a+mapEnumerator f e =+  Enumerator $ \n tss ->+    f (enumerate e n tss)++filterEnumerator :: (a -> Bool) -> Enumerator a -> Enumerator a+filterEnumerator p e =+  mapEnumerator (filter p) e++enumerateConstants :: Sized a => [a] -> Enumerator a+enumerateConstants ts = Enumerator (\n _ -> [t | t <- ts, size t == n])++enumerateApplications :: Apply a => Enumerator a+enumerateApplications = Enumerator $ \n tss ->+    [ unPoly v+    | i <- [0..n],+      t <- tss !! i,+      u <- tss !! (n-i),+      Just v <- [tryApply (poly t) (poly u)] ]++filterUniverse :: Typed f => Universe -> Enumerator (Term f) -> Enumerator (Term f)+filterUniverse univ e =+  filterEnumerator (`usefulForUniverse` univ) e++sortTerms :: Ord b => (a -> b) -> Enumerator a -> Enumerator a+sortTerms measure e =+  mapEnumerator (sortBy' measure) e++quickSpec ::+  (Ord fun, Ord norm, Sized fun, Typed fun, Ord result, PrettyTerm fun,+  MonadPruner (Term fun) norm m, MonadTester testcase (Term fun) m, MonadTerminal m) =>+  (Prop (Term fun) -> m ()) ->+  (Term fun -> testcase -> Maybe result) ->+  Int -> Int -> (Type -> VariableUse) -> Universe -> Enumerator (Term fun) -> m ()+quickSpec present eval maxSize maxCommutativeSize use univ enum = do+  let+    state0 = initialState use univ (\t -> size t <= maxCommutativeSize) eval++    loop m n _ | m > n = return ()+    loop m n tss = do+      putStatus (printf "enumerating terms of size %d" m)+      let+        ts = enumerate (filterUniverse univ enum) m tss+        total = length ts+        consider (i, t) = do+          putStatus (printf "testing terms of size %d: %d/%d" m i total)+          res <- explore t+          putStatus (printf "testing terms of size %d: %d/%d" m i total)+          lift $ mapM_ present (result_props res)+          case res of+            Accepted _ -> return True+            Rejected _ -> return False+      us <- map snd <$> filterM consider (zip [1 :: Int ..] ts)+      clearStatus+      loop (m+1) n (appendAt m us tss)++  evalStateT (loop 0 maxSize (repeat [])) state0++----------------------------------------------------------------------+-- Functions that are not really to do with theory exploration,+-- but are useful for printing the output nicely.+----------------------------------------------------------------------++pPrintSignature :: (Pretty a, Typed a) => [a] -> Doc+pPrintSignature funs =+  text "== Functions ==" $$+  vcat (map pPrintDecl decls)+  where+    decls = [ (prettyShow f, pPrintType (typ f)) | f <- funs ]+    maxWidth = maximum (0:map (length . fst) decls)+    pad xs = nest (maxWidth - length xs) (text xs)+    pPrintDecl (name, ty) =+      pad name <+> text "::" <+> ty++-- Put an equation that defines the function f into the form f lhs = rhs.+-- An equation defines f if:+--   * it is of the form f lhs = rhs (or vice versa).+--   * f is not a background function.+--   * lhs only contains background functions.+--   * rhs does not contain f.+--   * all vars in rhs appear in lhs+prettyDefinition :: Eq fun => [fun] -> Prop (Term fun) -> Prop (Term fun)+prettyDefinition cons (lhs :=>: t :=: u)+  | Just (f, ts) <- defines u,+    f `notElem` funs t,+    null (usort (vars t) \\ vars ts) =+    lhs :=>: u :=: t+    -- In the case where t defines f, the equation is already oriented correctly+  | otherwise = lhs :=>: t :=: u+  where+    defines (Fun f :@: ts)+      | f `elem` cons,+        all (`notElem` cons) (funs ts) = Just (f, ts)+    defines _ = Nothing++-- Transform x+(y+z) = y+(x+z) into associativity, if + is commutative+prettyAC :: (Eq f, Eq norm) => (Term f -> norm) -> Prop (Term f) -> Prop (Term f)+prettyAC norm (lhs :=>: Fun f :@: [Var x, Fun f1 :@: [Var y, Var z]] :=: Fun f2 :@: [Var y1, Fun f3 :@: [Var x1, Var z1]])+  | f == f1, f1 == f2, f2 == f3,+    x == x1, y == y1, z == z1,+    x /= y, y /= z, x /= z,+    norm (Fun f :@: [Var x, Var y]) == norm (Fun f :@: [Var y, Var x]) =+      lhs :=>: Fun f :@: [Fun f :@: [Var x, Var y], Var z] :=: Fun f :@: [Var x, Fun f :@: [Var y, Var z]]+prettyAC _ prop = prop++-- Add a type signature when printing the equation x = y.+disambiguatePropType :: Prop (Term fun) -> Doc+disambiguatePropType (_ :=>: (Var x) :=: Var _) =+  text "::" <+> pPrintType (typ x)+disambiguatePropType _ = pPrintEmpty
+ src/QuickSpec/Internal/Explore/Conditionals.hs view
@@ -0,0 +1,214 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveFunctor #-}+module QuickSpec.Internal.Explore.Conditionals where++import QuickSpec.Internal.Prop as Prop+import QuickSpec.Internal.Term as Term+import QuickSpec.Internal.Type+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Pruning.Background(Background(..))+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Terminal+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Explore.Polymorphic+import qualified Twee.Base as Twee+import Data.List+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.IO.Class++newtype Conditionals m a = Conditionals (m a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal)+instance MonadTrans Conditionals where+  lift = Conditionals+instance (Typed fun, Ord fun, PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  MonadPruner (Term fun) norm (Conditionals m) where+  normaliser = lift $ do+    norm <- normaliser+    return (norm . fmap Normal)+  add prop = do+    redundant <- conditionallyRedundant prop+    if redundant then return False else do+      res <- lift (add (Prop.mapFun Normal prop))+      considerConditionalising prop+      return res++  decodeNormalForm hole t = lift $ do+    t <- decodeNormalForm (fmap (fmap Normal) . hole) t+    let f (Normal x) = Just x+        f _ = Nothing+    return $ t >>= sequence . Term.mapFun f++conditionalsUniverse :: (Typed fun, Predicate fun) => [Type] -> [fun] -> Universe+conditionalsUniverse tys funs =+  universe $+    tys +++    (map typ $+      map Normal funs +++      [ Constructor pred clas_test_case | pred <- funs, Predicate{..} <- [classify pred] ])++runConditionals ::+  (PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  [fun] -> Conditionals m a -> m a+runConditionals preds mx =+  run (mapM_ considerPredicate preds >> mx)+  where+    run (Conditionals mx) = mx++class Predicate fun where+  classify :: fun -> Classification fun++data Classification fun =+    Predicate { clas_selectors :: [fun], clas_test_case :: Type, clas_true :: Term fun }+  | Selector { clas_index :: Int, clas_pred :: fun, clas_test_case :: Type }+  | Function+  deriving (Eq, Ord, Functor)++data WithConstructor fun =+    Constructor fun Type+  | Normal fun+  deriving (Eq, Ord)++instance Sized fun => Sized (WithConstructor fun) where+  size Constructor{} = 0+  size (Normal f) = size f++instance Pretty fun => Pretty (WithConstructor fun) where+  pPrintPrec l p (Constructor f _) = pPrintPrec l p f <#> text "_con"+  pPrintPrec l p (Normal f) = pPrintPrec l p f++instance PrettyTerm fun => PrettyTerm (WithConstructor fun) where+  termStyle (Constructor _ _) = curried+  termStyle (Normal f) = termStyle f++instance (Predicate fun, Background fun) => Background (WithConstructor fun) where+  background (Normal f) = map (Prop.mapFun Normal) (background f)+  background _ = []++instance Typed fun => Typed (WithConstructor fun) where+  typ (Constructor pred ty) =+    arrowType (typeArgs (typ pred)) ty+  typ (Normal f) = typ f+  otherTypesDL (Constructor pred _) = typesDL pred+  otherTypesDL (Normal f) = otherTypesDL f+  typeSubst_ sub (Constructor pred ty) = Constructor (typeSubst_ sub pred) (typeSubst_ sub ty)+  typeSubst_ sub (Normal f) = Normal (typeSubst_ sub f)++predType :: TyCon -> [Type] -> Type+predType name tys =+  Twee.build (Twee.app (Twee.fun name) tys)++considerPredicate ::+  (PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  fun -> Conditionals m ()+considerPredicate f =+  case classify f of+    Predicate sels ty true -> do+      let+        x = Var (V ty 0)+        eqns =+          [Fun (Constructor f ty) :@: [Fun (Normal sel) :$: x | sel <- sels] === x,+           Fun (Normal f) :@: [Fun (Normal sel) :$: x | sel <- sels] === fmap Normal true]+      mapM_ (lift . add) eqns+    _ -> return ()++considerConditionalising ::+  (Typed fun, Ord fun, PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  Prop (Term fun) -> Conditionals m ()+considerConditionalising (lhs :=>: t :=: u) = do+  norm <- normaliser+  -- If we have discovered that "somePredicate x_1 x_2 ... x_n = True"+  -- we should add the axiom "get_x_n (toSomePredicate x_1 x_2 ... x_n) = x_n"+  -- to the set of known equations+  case t of+    Fun f :@: ts | Predicate{..} <- classify f -> -- It is an interesting predicate, i.e. it was added by the user+      when (norm u == norm clas_true) $+        addPredicate lhs f ts+    _ -> return ()++conditionallyRedundant ::+  (Typed fun, Ord fun, PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  Prop (Term fun) -> Conditionals m Bool+conditionallyRedundant (lhs :=>: t :=: u) = do+  t' <- normalise t+  u' <- normalise u+  conditionallyRedundant' lhs t u t' u'++conditionallyRedundant' ::+  (Typed fun, Ord fun, PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  [Equation (Term fun)] -> Term fun -> Term fun -> norm -> norm -> Conditionals m Bool+conditionallyRedundant' lhs t u t' u' = do+  forM_ (usort (funs [t, u])) $ \f ->+    case classify f of+      Selector{..} -> do+        let+          Predicate{..} = classify clas_pred+          tys = typeArgs (typ clas_pred)+          argss = sequence [ [ arg | arg <- terms [t, u] >>= subterms, typ arg == ty ] | ty <- tys ]+        forM_ argss $ \args -> do+          norm <- normaliser+          let p = Fun clas_pred :@: args+          when (norm p == norm clas_true) $ do+            addPredicate lhs clas_pred args+      _ -> return ()++  t'' <- normalise t+  u'' <- normalise u+  if t'' == u'' then+    return True+   else if t'' == t' && u'' == u' then+     return False+    else+     conditionallyRedundant' lhs t u t'' u''++addPredicate ::+  (PrettyTerm fun, Ord norm, MonadPruner (Term (WithConstructor fun)) norm m, Predicate fun, MonadTerminal m) =>+  [Equation (Term fun)] -> fun -> [Term fun] -> Conditionals m ()+addPredicate lhs f ts = do+  let Predicate{..} = classify f+      ts' = map (fmap Normal) ts+      lhs' = map (fmap (fmap Normal)) lhs+      -- The "to_p x1 x2 ... xm" term+      construction = Fun (Constructor f clas_test_case) :@: ts'+      -- The "p_n (to_p x1 x2 ... xn ... xm) = xn"+      -- equations+      equations = [ lhs' :=>: Fun (Normal (clas_selectors !! i)) :$: construction :=: x | (x, i) <- zip ts' [0..]]++  -- Declare the relevant equations as axioms+  mapM_ (lift . add) equations++conditionalise :: (PrettyTerm fun, Typed fun, Ord fun, Predicate fun) => Prop (Term fun) -> Prop (Term fun)+conditionalise (lhs :=>: t :=: u) =+  go lhs t u+  where+    -- Replace one predicate with a conditional+    go lhs t u =+      case [ (p, x, clas_selectors, clas_true) | Fun f :$: Var x <- subterms t ++ subterms u, Selector _ p _ <- [classify f], Predicate{..} <- [classify p] ] of+        [] -> sort lhs :=>: t :=: u+        ((p, x, sels, true):_) ->+          let+            n = freeVar [t, u]+            tys = typeArgs (typ p)+            xs = map Var (zipWith V tys [n..])+            subs = [(Fun (sels !! i) :$: Var x, xs !! i) | i <- [0..length tys-1]]+          in+            go ((Fun p :@: xs :=: true):lhs) (replaceMany subs t) (replaceMany subs u)++    replace from to t+      | t == from = to+    replace from to (t :$: u) =+      replace from to t :$: replace from to u+    replace _ _ (Var x) = Var x+    replace _ _ (Fun f) = Fun f++    replaceMany subs t =+      foldr (uncurry replace) t subs
+ src/QuickSpec/Internal/Explore/Polymorphic.hs view
@@ -0,0 +1,283 @@+-- Theory exploration which handles polymorphism.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+module QuickSpec.Internal.Explore.Polymorphic(+  module QuickSpec.Internal.Explore.Polymorphic,+  Result(..),+  Universe(..),+  VariableUse(..)) where++import qualified QuickSpec.Internal.Explore.Schemas as Schemas+import QuickSpec.Internal.Explore.Schemas(Schemas, Result(..), VariableUse(..))+import QuickSpec.Internal.Term hiding (mapFun)+import QuickSpec.Internal.Type+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Terminal+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)+import Data.Lens.Light+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Class+import qualified Twee.Base as Twee+import Control.Monad+import qualified Data.DList as DList+import Data.Maybe++data Polymorphic testcase result fun norm =+  Polymorphic {+    pm_schemas :: Schemas testcase result (PolyFun fun) norm,+    pm_universe :: Universe }++data PolyFun fun =+  PolyFun { fun_original :: fun, fun_specialised :: fun }+  deriving (Eq, Ord)++instance Pretty fun => Pretty (PolyFun fun) where+  pPrint = pPrint . fun_specialised++instance PrettyTerm fun => PrettyTerm (PolyFun fun) where+  termStyle = termStyle . fun_specialised++-- The set of all types being explored+data Universe = Universe { univ_types :: Set Type }++schemas = lens pm_schemas (\x y -> y { pm_schemas = x })+univ = lens pm_universe (\x y -> y { pm_universe = x })++initialState ::+  (Type -> VariableUse) ->+  Universe ->+  (Term fun -> Bool) ->+  (Term fun -> testcase -> Maybe result) ->+  Polymorphic testcase result fun norm+initialState use univ inst eval =+  Polymorphic {+    pm_schemas = Schemas.initialState use (inst . fmap fun_specialised) (eval . fmap fun_specialised),+    pm_universe = univ }++polyFun :: Typed fun => fun -> PolyFun fun+polyFun x = PolyFun x (oneTypeVar x)++polyTerm :: Typed fun => Term fun -> Term (PolyFun fun)+polyTerm = oneTypeVar . fmap polyFun++instance Typed fun => Typed (PolyFun fun) where+  typ = typ . fun_specialised+  otherTypesDL = otherTypesDL . fun_specialised+  typeSubst_ _ x = x -- because it's supposed to be monomorphic++newtype PolyM testcase result fun norm m a = PolyM { unPolyM :: StateT (Polymorphic testcase result fun norm) m a }+  deriving (Functor, Applicative, Monad, MonadTerminal)++explore ::+  (PrettyTerm fun, Ord result, Ord norm, Typed fun, Ord fun, Apply (Term fun),+  MonadTester testcase (Term fun) m, MonadPruner (Term fun) norm m, MonadTerminal m) =>+  Term fun ->+  StateT (Polymorphic testcase result fun norm) m (Result fun)+explore t = do+  univ <- access univ+  unless (t `usefulForUniverse` univ) $+    error ("Type " ++ prettyShow (typ t) ++ " not in universe for " ++ prettyShow t)+  if not (t `inUniverse` univ) then+    return (Accepted [])+   else do+    res <- exploreNoMGU t+    case res of+      Rejected{} -> return res+      Accepted{} -> do+        ress <- forM (typeInstances univ t) $ \u ->+          exploreNoMGU u+        return res { result_props = concatMap result_props (res:ress) }++exploreNoMGU ::+  (PrettyTerm fun, Ord result, Ord norm, Typed fun, Ord fun, Apply (Term fun),+  MonadTester testcase (Term fun) m, MonadPruner (Term fun) norm m, MonadTerminal m) =>+  Term fun ->+  StateT (Polymorphic testcase result fun norm) m (Result fun)+exploreNoMGU t = do+  univ <- access univ+  if not (t `inUniverse` univ) then return (Rejected []) else do+    schemas1 <- access schemas+    (res, schemas2) <- unPolyM (runStateT (Schemas.explore (polyTerm t)) schemas1)+    schemas ~= schemas2+    return (mapProps (regeneralise . mapFun fun_original) res)+  where+    mapProps f (Accepted props) = Accepted (map f props)+    mapProps f (Rejected props) = Rejected (map f props)++instance (PrettyTerm fun, Ord fun, Typed fun, Apply (Term fun), MonadPruner (Term fun) norm m, MonadTerminal m) =>+  MonadPruner (Term (PolyFun fun)) norm (PolyM testcase result fun norm m) where+  normaliser = PolyM $ do+    norm <- normaliser+    return (norm . fmap fun_specialised)+  add prop = PolyM $ do+    univ <- access univ+    let insts = typeInstances univ (canonicalise (regeneralise (mapFun fun_original prop)))+    or <$> mapM add insts++  normTheorems = PolyM normTheorems++  decodeNormalForm hole t =+    PolyM $ do+      t <- decodeNormalForm (fmap (fmap fun_specialised) . hole) t+      return $ fmap (fmap (\f -> PolyFun f f)) t++instance MonadTester testcase (Term fun) m =>+  MonadTester testcase (Term (PolyFun fun)) (PolyM testcase result fun norm m) where+  test prop = PolyM $ lift (test (mapFun fun_original prop))+  retest testcase prop = PolyM $ lift (retest testcase (mapFun fun_original prop))++-- Given a property which only contains one type variable,+-- add as much polymorphism to the property as possible.+-- e.g.    map (f :: a -> a) (xs++ys) = map f xs++map f ys+-- becomes map (f :: a -> b) (xs++ys) = map f xs++map f ys.+regeneralise :: (PrettyTerm fun, Typed fun, Apply (Term fun)) => Prop (Term fun) -> Prop (Term fun)+regeneralise =+  -- First replace each type variable occurrence with a fresh+  -- type variable (generalise), then unify type variables+  -- where necessary to preserve well-typedness (restrict).+  restrict . unPoly . generalise+  where+    generalise (lhs :=>: rhs) =+      polyApply (:=>:) (polyList (map genLit lhs)) (genLit rhs)+    genLit (t :=: u) = polyApply (:=:) (genTerm t) (genTerm u)+    genTerm (Var (V ty x)) =+      -- It's tempting to return Var (V typeVar x) here.+      -- But this is wrong!+      -- In the case of the type (), we get the law x == y :: (),+      -- which we must not generalise to x == y :: a.+      poly (Var (V (genType ty) x))+    genTerm (Fun f) = poly (Fun f)+    genTerm (t :$: u) =+      let+        (t', u') = unPoly (polyPair (genTerm t) (genTerm u))+        Just ty = fmap unPoly (polyMgu (polyTyp (poly t')) (polyApply (\arg res -> arrowType [arg] res) (polyTyp (poly u')) (poly typeVar)))+        Just (arg, _) = unpackArrow ty+        Just t'' = cast ty t'+        Just u'' = cast arg u'+      in+        poly (t'' :$: u'')++    genType = Twee.build . aux 0 . Twee.singleton+      where+        aux !_ Twee.Empty = mempty+        aux n (Twee.Cons (Twee.Var _) ts) =+          Twee.var (Twee.V n) `mappend` aux (n+1) ts+        aux n (Twee.Cons (Twee.App f ts) us) =+          Twee.app f (aux n ts) `mappend`+          aux (n+Twee.lenList ts) us++    restrict prop = typeSubst sub prop+      where+        Just sub = Twee.unifyList (Twee.buildList (map fst cs)) (Twee.buildList (map snd cs))+        cs = [(var_ty x, var_ty y) | x:xs <- vs, y <- xs] ++ concatMap litCs (lhs prop) ++ litCs (rhs prop)+        -- Two variables that were equal before generalisation must have the+        -- same type afterwards+        vs = partitionBy skel (concatMap vars (terms prop))+        skel (V ty x) = V (oneTypeVar ty) x+    litCs (t :=: u) = [(typ t, typ u)]++typeInstancesList :: [Type] -> [Type] -> [Twee.Var -> Type]+typeInstancesList types prop =+  map eval+    (foldr intersection [Map.empty]+      (map constrain+        (usort prop)))+  where+    constrain t =+      usort [ Map.fromList (Twee.substToList sub) | u <- types, Just sub <- [Twee.match t u] ]+    eval sub x =+      Map.findWithDefault (error ("not found: " ++ prettyShow x)) x sub++typeInstances :: (Pretty a, PrettyTerm fun, Symbolic fun a, Ord fun, Typed fun, Typed a) => Universe -> a -> [a]+typeInstances Universe{..} prop =+  [ typeSubst sub prop+  | sub <- typeInstancesList (Set.toList univ_types) (map typ (DList.toList (termsDL prop) >>= subtermsFO)) ]++intersection :: [Map Twee.Var Type] -> [Map Twee.Var Type] -> [Map Twee.Var Type]+ms1 `intersection` ms2 = usort [ Map.union m1 m2 | m1 <- ms1, m2 <- ms2, ok m1 m2 ]+  where+    ok m1 m2 = and [ Map.lookup x m1 == Map.lookup x m2 | x <- Map.keys (Map.intersection m1 m2) ]++universe :: Typed a => [a] -> Universe+universe xs = Universe (Set.fromList univ)+  where+    -- Types of all functions+    types = usort $ typeVar:map typ xs++    -- Take the argument and result type of every function.+    univBase = usort $ concatMap components types++    -- Add partially-applied functions, if they can be used to+    -- fill in a higher-order argument.+    univHo = usort $ concatMap addHo univBase+      where+        addHo ty =+          ty:+          [ typeSubst sub ho+          | fun <- types,+            ho <- arrows fun,+            sub <- typeInstancesList univBase (components fun) ]+  +    -- Finally, close the universe under the following operations:+    -- * Unifying two types+    -- * Unifying a function's argument with another type+    --   (the closure includes the function type, the argument type+    --   and the result type)+    -- but only if some type in the universe is an instance of the+    -- resulting type. The idea is that, if some term can be built+    -- whose type is a generalisation of the type in the universe,+    -- that generalised type should also be in the universe.+    univ = oneTypeVar (fixpoint (usort . map canonicaliseType . mgus . prune) univHo)+      where+        prune tys = filter (not . subsumed) tys+          where+            subsumed ty =+              or [oneTypeVar pat == oneTypeVar ty && isJust (matchType pat ty) && isNothing (matchType ty pat) | pat <- tys]+        mgus tys =+          tys +++          [ ty+          | ty1 <- tys, ty2 <- tys, +            ty <- unPoly <$> combine (poly ty1) (poly ty2),+            or [isJust (matchType ty bound) | bound <- tys] ]+        combine ty1 ty2 =+          catMaybes [polyMgu ty1 ty2 | ty1 < ty2] +++          maybeToList (tryApply ty1 ty2) +++          -- Get the function and argument types used by tryApply+          concat [[poly x, poly y] | (x, y) <- maybeToList (unPoly <$> polyFunctionMgu ty1 ty2)]++    components ty =+      case unpackArrow ty of+        Nothing -> [ty]+        Just (ty1, ty2) -> components ty1 ++ components ty2++    arrows ty =+      concatMap arrows1 (typeArgs ty)+      where+        arrows1 ty =+          case unpackArrow ty of+            Just (arg, res) ->+              [ty] ++ arrows1 arg ++ arrows1 res+            _ -> []+ +inUniverse :: (PrettyTerm fun, Typed fun) => Term fun -> Universe -> Bool+t `inUniverse` Universe{..} =+  and [oneTypeVar (typ u) `Set.member` univ_types | u <- subtermsFO t ++ map Var (vars t)]++usefulForUniverse :: Typed fun => Term fun -> Universe -> Bool+t `usefulForUniverse` Universe{..} =+  and [oneTypeVar (typ u) `Set.member` univ_types | u <- properSubtermsFO t ++ map Var (vars t)] &&+  oneTypeVar (typeRes (typ t)) `Set.member` univ_types
+ src/QuickSpec/Internal/Explore/Schemas.hs view
@@ -0,0 +1,194 @@+-- Theory exploration which works on a schema at a time.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RecordWildCards, FlexibleContexts, PatternGuards, TupleSections, MultiParamTypeClasses, FlexibleInstances #-}+module QuickSpec.Internal.Explore.Schemas where++import qualified Data.Map.Strict as Map+import Data.Map(Map)+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Term+import QuickSpec.Internal.Type+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Terminal+import qualified QuickSpec.Internal.Explore.Terms as Terms+import QuickSpec.Internal.Explore.Terms(Terms)+import Control.Monad.Trans.State.Strict hiding (State)+import Data.List+import Data.Ord+import Data.Lens.Light+import qualified Data.Set as Set+import Data.Set(Set)+import Data.Maybe+import Control.Monad+import Data.Label++-- | Constrains how variables of a particular type may occur in a term.+data VariableUse =+    UpTo Int -- ^ @UpTo n@: terms may contain up to @n@ distinct variables of this type+             -- (in some cases, laws with more variables may still be found)+  | Linear   -- ^ Each variable in the term must be distinct+  deriving (Eq, Show)++data Schemas testcase result fun norm =+  Schemas {+    sc_use :: Type -> VariableUse,+    sc_instantiate_singleton :: Term fun -> Bool,+    sc_empty :: Terms testcase result (Term fun) norm,+    sc_classes :: Terms testcase result (Term fun) norm,+    sc_instantiated :: Set (Term fun),+    sc_instances :: Map (Term fun) (Terms testcase result (Term fun) norm) }++classes = lens sc_classes (\x y -> y { sc_classes = x })+use = lens sc_use (\x y -> y { sc_use = x })+instances = lens sc_instances (\x y -> y { sc_instances = x })+instantiated = lens sc_instantiated (\x y -> y { sc_instantiated = x })++instance_ :: Ord fun => Term fun -> Lens (Schemas testcase result fun norm) (Terms testcase result (Term fun) norm)+instance_ t = reading (\Schemas{..} -> keyDefault t sc_empty # instances)++initialState ::+  (Type -> VariableUse) ->+  (Term fun -> Bool) ->+  (Term fun -> testcase -> Maybe result) ->+  Schemas testcase result fun norm+initialState use inst eval =+  Schemas {+    sc_use = use,+    sc_instantiate_singleton = inst,+    sc_empty = Terms.initialState eval,+    sc_classes = Terms.initialState eval,+    sc_instantiated = Set.empty,+    sc_instances = Map.empty }++data Result fun =+    Accepted { result_props :: [Prop (Term fun)] }+  | Rejected { result_props :: [Prop (Term fun)] }++-- The schema is represented as a term where there is only one distinct variable of each type+explore ::+  (PrettyTerm fun, Ord result, Ord fun, Ord norm, Typed fun,+  MonadTester testcase (Term fun) m, MonadPruner (Term fun) norm m, MonadTerminal m) =>+  Term fun -> StateT (Schemas testcase result fun norm) m (Result fun)+explore t0 = do+  use <- access use+  if or [use ty == UpTo 0 | ty <- usort (map typ (vars t0))] then return (Rejected []) else do+    let t = mostSpecific t0+    res <- zoom classes (Terms.explore t)+    case res of+      Terms.Singleton -> do+        inst <- gets sc_instantiate_singleton+        if inst t then+          instantiateRep t+         else do+          -- Add the most general instance of the schema+          zoom (instance_ t) (Terms.explore (mostGeneral use t0))+          return (Accepted [])+      Terms.Discovered ([] :=>: _ :=: u) ->+        exploreIn u t+      Terms.Knew ([] :=>: _ :=: u) ->+        exploreIn u t+      _ -> error "term layer returned non-equational property"++{-# INLINEABLE exploreIn #-}+exploreIn ::+  (PrettyTerm fun, Ord result, Ord fun, Ord norm, Typed fun,+  MonadTester testcase (Term fun) m, MonadPruner (Term fun) norm m, MonadTerminal m) =>+  Term fun -> Term fun ->+  StateT (Schemas testcase result fun norm) m (Result fun)+exploreIn rep t = do+  -- First check if schema is redundant+  use <- access use+  res <- zoom (instance_ rep) (Terms.explore (mostGeneral use t))+  case res of+    Terms.Discovered prop -> do+      add prop+      return (Rejected [prop])+    Terms.Knew _ ->+      return (Rejected [])+    Terms.Singleton -> do+      -- Instantiate rep too if not already done+      inst <- access instantiated+      props <-+        if Set.notMember rep inst+        then result_props <$> instantiateRep rep+        else return []+      res <- instantiate rep t+      return res { result_props = props ++ result_props res }++{-# INLINEABLE instantiateRep #-}+instantiateRep ::+  (PrettyTerm fun, Ord result, Ord fun, Ord norm, Typed fun,+  MonadTester testcase (Term fun) m, MonadPruner (Term fun) norm m, MonadTerminal m) =>+  Term fun ->+  StateT (Schemas testcase result fun norm) m (Result fun)+instantiateRep t = do+  instantiated %= Set.insert t+  instantiate t t++{-# INLINEABLE instantiate #-}+instantiate ::+  (PrettyTerm fun, Ord result, Ord fun, Ord norm, Typed fun,+  MonadTester testcase (Term fun) m, MonadPruner (Term fun) norm m, MonadTerminal m) =>+  Term fun -> Term fun ->+  StateT (Schemas testcase result fun norm) m (Result fun)+instantiate rep t = do+  use <- access use+  zoom (instance_ rep) $ do+    let instances = sortBy (comparing generality) (allUnifications use (mostGeneral use t))+    Accepted <$> catMaybes <$> forM instances (\t -> do+      res <- Terms.explore t+      case res of+        Terms.Discovered prop -> do+          res <- add prop+          if res then return (Just prop) else return Nothing+        _ -> return Nothing)++-- sortBy (comparing generality) should give most general instances first.+generality :: Term f -> (Int, [Var])+generality t = (-length (usort (vars t)), vars t)++mkVar :: Type -> Int -> Var+mkVar ty n = V ty m+  -- Try to make sure that variables of different types don't end up with the+  -- same number. It would be better to deal with this in QuickSpec.Term.+  -- (Note: the problem we are trying to avoid is that, if two variables have+  -- the same number and different but unifiable types, then a type substitution+  -- can turn them into the same variable.)+  where+    m = fromIntegral (labelNum (label (ty, n)))++-- | Instantiate a schema by making all the variables different.+mostGeneral :: (Type -> VariableUse) -> Term f -> Term f+mostGeneral use s = evalState (aux s) Map.empty+  where+    aux (Var (V ty _)) = do+      m <- get+      let n :: Int+          n = Map.findWithDefault 0 ty m+      unless (use ty == UpTo 1) $+        put $! Map.insert ty (n+1) m+      return (Var (mkVar ty n))+    aux (Fun f) = return (Fun f)+    aux (t :$: u) = liftM2 (:$:) (aux t) (aux u)++mostSpecific :: Term f -> Term f+mostSpecific = subst (\(V ty _) -> Var (mkVar ty 0))++allUnifications :: (Type -> VariableUse) -> Term fun -> [Term fun]+allUnifications use t =+  [ subst (\x -> Var (Map.findWithDefault undefined x s)) t | s <- ss ]+  where+    ss =+      map Map.fromList $ map concat $ sequence+        [substsFor xs (typ y) | xs@(y:_) <- partitionBy typ (usort (vars t))]++    substsFor xs ty =+      case use ty of+        UpTo k ->+          sequence [[(x, v) | v <- take k vs] | x <- xs]+        Linear ->+          map (zip xs) (permutations (take (length xs) vs))+      where+        vs = map (mkVar ty) [0..]
+ src/QuickSpec/Internal/Explore/Terms.hs view
@@ -0,0 +1,108 @@+-- Theory exploration which accepts one term at a time.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RecordWildCards, FlexibleContexts, PatternGuards #-}+module QuickSpec.Internal.Explore.Terms where++import qualified Data.Map.Strict as Map+import Data.Map(Map)+import QuickSpec.Internal.Term+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Type+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Testing.DecisionTree hiding (Result, Singleton)+import Control.Monad.Trans.State.Strict hiding (State)+import Data.Lens.Light+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Terminal++data Terms testcase result term norm =+  Terms {+    -- Empty decision tree.+    tm_empty :: DecisionTree testcase result term,+    -- Terms already explored. These are stored in the *values* of the map.+    -- The keys are those terms but normalised.+    -- We do it like this so that explore can guarantee to always return+    -- the same representative for each equivalence class (see below).+    tm_terms  :: Map norm term,+    -- Decision tree mapping test case results to terms.+    -- Terms are not stored normalised.+    -- Terms of different types must not be equal, because that results in+    -- ill-typed equations and bad things happening in the pruner.+    tm_tree   :: Map Type (DecisionTree testcase result term) }++tree = lens tm_tree (\x y -> y { tm_tree = x })++treeForType :: Type -> Lens (Terms testcase result term norm) (DecisionTree testcase result term)+treeForType ty = reading (\Terms{..} -> keyDefault ty tm_empty # tree)++initialState ::+  (term -> testcase -> Maybe result) ->+  Terms testcase result term norm+initialState eval =+  Terms {+    tm_empty = empty eval,+    tm_terms = Map.empty,+    tm_tree = Map.empty }++data Result term =+    -- Discovered a new law.+    Discovered (Prop term)+    -- Term is equal to an existing term so redundant.+  | Knew (Prop term)+  | Singleton++-- The Prop returned is always t :=: u, where t is the term passed to explore+-- and u is the representative of t's equivalence class, not normalised.+-- The representatives of the equivalence classes are guaranteed not to change.+--+-- Discovered properties are not added to the pruner.+explore :: (Pretty term, Typed term, Ord norm, Ord result, MonadTester testcase term m, MonadPruner term norm m, MonadTerminal m) =>+  term -> StateT (Terms testcase result term norm) m (Result term)+explore t = do+  res <- explore' t+  --case res of+  --  Discovered prop -> putLine ("discovered " ++ prettyShow prop)+  --  Knew prop -> putLine ("knew " ++ prettyShow prop)+  --  Singleton -> putLine ("singleton " ++ prettyShow t)+  return res+explore' :: (Pretty term, Typed term, Ord norm, Ord result, MonadTester testcase term m, MonadPruner term norm m) =>+  term -> StateT (Terms testcase result term norm) m (Result term)+explore' t = do+  norm <- normaliser+  exp norm $ \prop -> do+    res <- test prop+    case res of+      Untestable ->+        return Singleton+      TestPassed -> do+        return (Discovered prop)+      TestFailed tc -> do+        treeForType ty %= addTestCase tc+        exp norm $+          error "returned counterexample failed to falsify property"++  where+    ty = typ t+    exp norm found = do+      tm@Terms{..} <- get+      case Map.lookup t' tm_terms of+        Just u -> return (Knew (t === u))+        Nothing ->+          case insert t (tm ^. treeForType ty) of+            Distinct tree -> do+              put (setL (treeForType ty) tree tm { tm_terms = Map.insert t' t tm_terms })+              return Singleton+            EqualTo u+              -- tm_terms is not kept normalised wrt the discovered laws;+              -- instead, we normalise it lazily like so.+              | t' == u' -> do+                put tm { tm_terms = Map.insert u' u tm_terms }+                return (Knew prop)+              -- Ask QuickCheck for a counterexample to the property.+              | otherwise -> found prop+              where+                u' = norm u+                prop = t === u+      where+        t' = norm t
+ src/QuickSpec/Internal/Haskell.hs view
@@ -0,0 +1,888 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE Haskell2010 #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ConstraintKinds #-}+module QuickSpec.Internal.Haskell where++import QuickSpec.Internal.Haskell.Resolve+import QuickSpec.Internal.Type+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Pruning+import Test.QuickCheck hiding (total, classify, subterms, Fun)+import Data.Constraint hiding ((\\))+import Data.Proxy+import qualified Twee.Base as Twee+import QuickSpec.Internal.Term+import Data.Functor.Identity+import Data.Maybe+import Data.MemoUgly+import Test.QuickCheck.Gen.Unsafe+import Data.Char+import Data.Ord+import QuickSpec.Internal.Testing+import qualified QuickSpec.Internal.Testing.QuickCheck as QuickCheck+import qualified QuickSpec.Internal.Pruning.Twee as Twee+import QuickSpec.Internal.Explore hiding (quickSpec)+import qualified QuickSpec.Internal.Explore+import QuickSpec.Internal.Explore.Polymorphic(Universe(..), VariableUse(..))+import QuickSpec.Internal.Pruning.Background(Background)+import Control.Monad+import Control.Monad.Trans.State.Strict+import QuickSpec.Internal.Terminal+import Text.Printf+import QuickSpec.Internal.Utils+import Data.Lens.Light+import GHC.TypeLits+import QuickSpec.Internal.Explore.Conditionals hiding (Normal)+import Control.Spoon+import qualified Data.Set as Set+import qualified Test.QuickCheck.Poly as Poly+import Numeric.Natural(Natural)+import Test.QuickCheck.Instances()+import Data.Word+import Data.List.NonEmpty (NonEmpty)+import Data.Complex+import Data.Ratio+import Data.Functor.Compose+import Data.Int+import Data.Void+import Data.Unique+import qualified Data.Monoid as DM+import qualified Data.Semigroup as DS+import qualified Data.Map.Strict as Map+import Test.QuickCheck.Gen+import Test.QuickCheck.Random++baseInstances :: Instances+baseInstances =+  mconcat [+    -- Generate tuple values (pairs and () are built into findInstance)+    inst $ \(x :: A) (y :: B) (z :: C) -> (x, y, z),+    inst $ \(x :: A) (y :: B) (z :: C) (w :: D) -> (x, y, z, w),+    inst $ \(x :: A) (y :: B) (z :: C) (w :: D) (v :: E) -> (x, y, z, w, v),+    -- Split conjunctions of typeclasses into individuals+    inst $ \() -> Dict :: Dict (),+    inst $ \(Dict :: Dict ClassA) (Dict :: Dict ClassB) -> Dict :: Dict (ClassA, ClassB),+    inst $ \(Dict :: Dict ClassA) (Dict :: Dict ClassB) (Dict :: Dict ClassC) -> Dict :: Dict (ClassA, ClassB, ClassC),+    inst $ \(Dict :: Dict ClassA) (Dict :: Dict ClassB) (Dict :: Dict ClassC) (Dict :: Dict ClassD) -> Dict :: Dict (ClassA, ClassB, ClassC, ClassD),+    inst $ \(Dict :: Dict ClassA) (Dict :: Dict ClassB) (Dict :: Dict ClassC) (Dict :: Dict ClassD) (Dict :: Dict ClassE) -> Dict :: Dict (ClassA, ClassB, ClassC, ClassD, ClassE),+    inst $ \(Dict :: Dict ClassA) (Dict :: Dict ClassB) (Dict :: Dict ClassC) (Dict :: Dict ClassD) (Dict :: Dict ClassE) (Dict :: Dict ClassF) -> Dict :: Dict (ClassA, ClassB, ClassC, ClassD, ClassE, ClassF),+    -- Derive typeclass instances using (:-)+    -- N.B. flip is there to resolve (:-) first to reduce backtracking+    inst $ flip $ \(Dict :: Dict ClassA) (Sub Dict :: ClassA :- ClassB) -> Dict :: Dict ClassB,+    -- Standard names+    inst $ \(Names names :: Names A) ->+      Names (map (++ "s") names) :: Names [A],+    inst (Names ["p", "q", "r"] :: Names (A -> Bool)),+    inst (Names ["f", "g", "h"] :: Names (A -> B)),+    inst (Names ["dict"] :: Names (Dict ClassA)),+    inst (Names ["x", "y", "z", "w"] :: Names A),+    -- Allow up to 4 variables per type by default+    inst (Use (UpTo 4) :: Use A),+    -- Standard instances+    baseType (Proxy :: Proxy ()),+    baseType (Proxy :: Proxy Int),+    baseType (Proxy :: Proxy Integer),+    baseType (Proxy :: Proxy Natural),+    baseType (Proxy :: Proxy Bool),+    baseType (Proxy :: Proxy Char),+    baseType (Proxy :: Proxy Poly.OrdA),+    baseType (Proxy :: Proxy Poly.OrdB),+    baseType (Proxy :: Proxy Poly.OrdC),+    inst (Sub Dict :: () :- CoArbitrary ()),+    inst (Sub Dict :: () :- CoArbitrary Int),+    inst (Sub Dict :: () :- CoArbitrary Integer),+    inst (Sub Dict :: () :- CoArbitrary Natural),+    inst (Sub Dict :: () :- CoArbitrary Bool),+    inst (Sub Dict :: () :- CoArbitrary Char),+    inst (Sub Dict :: () :- CoArbitrary Poly.OrdA),+    inst (Sub Dict :: () :- CoArbitrary Poly.OrdB),+    inst (Sub Dict :: () :- CoArbitrary Poly.OrdC),+    inst (Sub Dict :: Eq A :- Eq [A]),+    inst (Sub Dict :: Ord A :- Ord [A]),+    inst (Sub Dict :: Arbitrary A :- Arbitrary [A]),+    inst (Sub Dict :: CoArbitrary A :- CoArbitrary [A]),+    inst (Sub Dict :: Eq A :- Eq (Maybe A)),+    inst (Sub Dict :: Ord A :- Ord (Maybe A)),+    inst (Sub Dict :: Arbitrary A :- Arbitrary (Maybe A)),+    inst (Sub Dict :: CoArbitrary A :- CoArbitrary (Maybe A)),+    inst (Sub Dict :: (Eq A, Eq B) :- Eq (Either A B)),+    inst (Sub Dict :: (Ord A, Ord B) :- Ord (Either A B)),+    inst (Sub Dict :: (Arbitrary A, Arbitrary B) :- Arbitrary (Either A B)),+    inst (Sub Dict :: (CoArbitrary A, CoArbitrary B) :- CoArbitrary (Either A B)),+    inst (Sub Dict :: (Eq A, Eq B) :- Eq (A, B)),+    inst (Sub Dict :: (Ord A, Ord B) :- Ord (A, B)),+    inst (Sub Dict :: (Arbitrary A, Arbitrary B) :- Arbitrary (A, B)),+    inst (Sub Dict :: (CoArbitrary A, CoArbitrary B) :- CoArbitrary (A, B)),+    inst (Sub Dict :: (Eq A, Eq B, Eq C) :- Eq (A, B, C)),+    inst (Sub Dict :: (Ord A, Ord B, Ord C) :- Ord (A, B, C)),+    inst (Sub Dict :: (Arbitrary A, Arbitrary B, Arbitrary C) :- Arbitrary (A, B, C)),+    inst (Sub Dict :: (CoArbitrary A, CoArbitrary B, CoArbitrary C) :- CoArbitrary (A, B, C)),+    inst (Sub Dict :: (Eq A, Eq B, Eq C, Eq D) :- Eq (A, B, C, D)),+    inst (Sub Dict :: (Ord A, Ord B, Ord C, Ord D) :- Ord (A, B, C, D)),+    inst (Sub Dict :: (Arbitrary A, Arbitrary B, Arbitrary C, Arbitrary D) :- Arbitrary (A, B, C, D)),+    inst (Sub Dict :: (CoArbitrary A, CoArbitrary B, CoArbitrary C, CoArbitrary D) :- CoArbitrary (A, B, C, D)),+    inst (Sub Dict :: (CoArbitrary A, Arbitrary B) :- Arbitrary (A -> B)),+    inst (Sub Dict :: (Arbitrary A, CoArbitrary B) :- CoArbitrary (A -> B)),+    inst (Sub Dict :: Ord A :- Eq A),+    -- From Arbitrary to Gen+    inst $ \(Dict :: Dict (Arbitrary A)) -> arbitrary :: Gen A,+    -- Observation functions+    inst $ \(Dict :: Dict (Ord A)) -> OrdInstance :: OrdInstance A,+    inst (\(Dict :: Dict (Observe A B C)) -> observeObs :: ObserveData C B),+    inst (\(Dict :: Dict (Ord A)) -> observeOrd :: ObserveData A A),+    inst (\(Dict :: Dict (Arbitrary A)) (obs :: ObserveData B C) -> observeFunction obs :: ObserveData (A -> B) C),+    inst (\(obs :: ObserveData A B) -> WrappedObserveData (toValue obs)),+    -- No warnings for TestCaseWrapped+    inst (NoWarnings :: NoWarnings (TestCaseWrapped SymA A)),+    -- Needed for typeclass-polymorphic predicates to work currently+    inst (\(Dict :: Dict ClassA) -> Dict :: Dict (Arbitrary (Dict ClassA)))]++data OrdInstance a where+  OrdInstance :: Ord a => OrdInstance a++-- A token used in the instance list for types that shouldn't generate warnings+data NoWarnings a = NoWarnings++data Use a = Use VariableUse++instance c => Arbitrary (Dict c) where+  arbitrary = return Dict++-- | A typeclass for types which support observational equality, typically used+-- for types that have no `Ord` instance.+--+-- An instance @Observe test outcome a@ declares that values of type @a@ can be+-- /tested/ for equality by random testing. You supply a function+-- @observe :: test -> outcome -> a@. Then, two values @x@ and @y@ are considered+-- equal, if for many random values of type @test@, @observe test x == observe test y@.+--+-- The function `QuickSpec.monoTypeObserve` declares a monomorphic+-- type with an observation function. For polymorphic types, use+-- `QuickSpec.inst` to declare the `Observe` instance.+--+-- For an example of using observational equality, see @<https://github.com/nick8325/quickspec/tree/master/examples/PrettyPrinting.hs PrettyPrinting.hs>@.+class (Arbitrary test, Ord outcome) => Observe test outcome a | a -> test outcome where+  -- | Make an observation on a value. Should satisfy the following law: if+  -- @x /= y@, then there exists a value of @test@ such that @observe test x /= observe test y@.+  observe :: test -> a -> outcome++  default observe :: (test ~ (), outcome ~ a) => test -> a -> outcome+  observe _ x = x++instance (Arbitrary a, Observe test outcome b) => Observe (a, test) outcome (a -> b) where+  observe (x, obs) f = observe obs (f x)++instance Observe () Int Int+instance Observe () Int8 Int8+instance Observe () Int16 Int16+instance Observe () Int32 Int32+instance Observe () Int64 Int64+instance Observe () Float Float+instance Observe () Double Double+instance Observe () Word Word+instance Observe () Word8 Word8+instance Observe () Word16 Word16+instance Observe () Word32 Word32+instance Observe () Word64 Word64+instance Observe () Integer Integer+instance Observe () Char Char+instance Observe () Bool Bool+instance Observe () Ordering Ordering+instance Observe () Void Void+instance Observe () Unique Unique+instance Observe () Natural Natural+instance Observe () DS.All DS.All+instance Observe () DS.Any DS.Any+instance Observe () () ()+instance (Observe xt xo x, Observe yt yo y)+      => Observe (xt, yt) (xo, yo) (x, y) where+  observe (xt, yt) (x, y)+    = (observe xt x, observe yt y)+instance (Observe xt xo x, Observe yt yo y, Observe zt zo z)+      => Observe (xt, yt, zt) (xo, yo, zo) (x, y, z) where+  observe (xt, yt, zt) (x, y, z)+    = (observe xt x, observe yt y, observe zt z)+instance (Observe xt xo x, Observe yt yo y, Observe zt zo z, Observe wt wo w)+      => Observe (xt, yt, zt, wt) (xo, yo, zo, wo) (x, y, z, w) where+  observe (xt, yt, zt, wt) (x, y, z, w)+    = (observe xt x, observe yt y, observe zt z, observe wt w)+instance Observe t p a => Observe t [p] [a] where+  observe t ps = fmap (observe t) ps+instance Observe t p a => Observe t (NonEmpty p) (NonEmpty a) where+  observe t ps = fmap (observe t) ps+instance Observe t p a => Observe (t, t) (p, p) (Complex a) where+  observe (t1, t2) (p1 :+ p2) = (observe t1 p1, observe t2 p2)+instance Observe t p a => Observe (t, t) (p, p) (Ratio a) where+  observe (t1, t2) (p)+    = (observe t1 $ numerator p, observe t2 $ denominator p)+instance Observe t p a => Observe t p (Identity a) where+  observe t = observe t . runIdentity+instance Observe t p (f (g a)) => Observe t p (Compose f g a) where+  observe t = observe t . getCompose+instance (Observe at ao a, Observe bt bo b)+      => Observe (at, bt) (Either ao bo) (Either a b) where+  observe (at, _) (Left a)  = Left $ observe at a+  observe (_, bt) (Right b) = Right $ observe bt b+instance Observe t p a => Observe t p (DS.Sum a) where+  observe t = observe t . DS.getSum+instance Observe t p a => Observe t p (DS.Product a) where+  observe t = observe t . DS.getProduct+instance Observe t p a => Observe t p (DS.First a) where+  observe t = observe t . DS.getFirst+instance Observe t p a => Observe t p (DS.Last a) where+  observe t = observe t . DS.getLast+instance Observe t p a => Observe t p (DS.Dual a) where+  observe t = observe t . DS.getDual+instance Observe t p a => Observe t p (DS.Min a) where+  observe t = observe t . DS.getMin+instance Observe t p a => Observe t p (DS.Max a) where+  observe t = observe t . DS.getMax+instance Observe t p a => Observe t p (DS.WrappedMonoid a) where+  observe t = observe t . DS.unwrapMonoid+instance Observe t p (f a) => Observe t p (DM.Alt f a) where+  observe t = observe t . DM.getAlt+instance Observe t p (f a) => Observe t p (DM.Ap f a) where+  observe t = observe t . DM.getAp+instance Observe t p a => Observe t (Maybe p) (DM.First a) where+  observe t = observe t . DM.getFirst+instance Observe t p a => Observe t (Maybe p) (DM.Last a) where+  observe t = observe t . DM.getLast+#if !MIN_VERSION_base(4,16,0)+instance Observe t p a => Observe t (Maybe p) (DS.Option a) where+  observe t = observe t . DS.getOption+#endif+instance Observe t p a => Observe t (Maybe p) (Maybe a) where+  observe t (Just a) = Just $ observe t a+  observe _ Nothing  = Nothing+instance (Arbitrary a, Observe t p a) => Observe (a, t) p (DS.Endo a) where+  observe t = observe t . DS.appEndo+++-- | Like 'Test.QuickCheck.===', but using the 'Observe' typeclass instead of 'Eq'.+(=~=) :: (Show test, Show outcome, Observe test outcome a) => a -> a -> Property+a =~= b = property $ \test -> observe test a Test.QuickCheck.=== observe test b+infix 4 =~=++-- An observation function along with instances.+-- The parameters are in this order so that we can use findInstance to get at appropriate Wrappers.+data ObserveData a outcome where+  ObserveData :: (Arbitrary test, Ord outcome) => (test -> a -> outcome) -> ObserveData a outcome+newtype WrappedObserveData a = WrappedObserveData (Value (ObserveData a))++observeOrd :: Ord a => ObserveData a a+observeOrd = ObserveData (\() x -> x)++observeFunction :: Arbitrary a => ObserveData b outcome -> ObserveData (a -> b) outcome+observeFunction (ObserveData obs) =+  ObserveData (\(x, test) f -> obs test (f x))++observeObs :: Observe test outcome a => ObserveData a outcome+observeObs = ObserveData observe++baseType :: forall proxy a. (Ord a, Arbitrary a, Typeable a) => proxy a -> Instances+baseType _ =+  mconcat [+    inst (Dict :: Dict (Ord a)),+    inst (Dict :: Dict (Arbitrary a))]++-- Declares what variable names should be used for values of a particular type.+newtype Names a = Names { getNames :: [String] }++names :: Instances -> Type -> [String]+names insts ty =+  case findInstance insts (skolemiseTypeVars ty) of+    Just x  -> ofValue getNames x+    Nothing -> error "don't know how to name variables"++-- An Ordy a represents a value of type a together with its Ord instance.+-- A Value Ordy is a value of unknown type which implements Ord.+data Ordy a where Ordy :: Ord a => a -> Ordy a+instance Eq (Value Ordy) where x == y = compare x y == EQ++instance Ord (Value Ordy) where+  compare x y =+    case unwrap x of+      Ordy xv `In` w ->+        let Ordy yv = reunwrap w y in+        compare xv yv++-- | A test case is everything you need to evaluate a Haskell term.+data TestCase =+  TestCase {+    -- | Evaluate a variable. Returns @Nothing@ if no `Arbitrary` instance was found.+    tc_eval_var :: Var -> Maybe (Value Identity),+    -- | Apply an observation function to get a value implementing `Ord`.+    -- Returns @Nothing@ if no observer was found.+    tc_test_result :: Value Identity -> Maybe (Value Ordy) }++-- | Generate a random test case.+arbitraryTestCase :: Type -> Instances -> Gen TestCase+arbitraryTestCase def insts =+  TestCase <$> arbitraryValuation def insts <*> arbitraryObserver def insts++-- | Generate a random variable valuation.+arbitraryValuation :: Type -> Instances -> Gen (Var -> Maybe (Value Identity))+arbitraryValuation def insts = do+  memo <$> arbitraryFunction (sequence . findGenerator def insts . var_ty)++-- | Generate a random observation.+arbitraryObserver :: Type -> Instances -> Gen (Value Identity -> Maybe (Value Ordy))+arbitraryObserver def insts = do+  find <- arbitraryFunction $ sequence . findObserver insts+  return $ \x -> do+    obs <- find (defaultTo def (typ x))+    return (obs x)++findGenerator :: Type -> Instances -> Type -> Maybe (Gen (Value Identity))+findGenerator def insts ty =+  bringFunctor <$> (findInstance insts (defaultTo def ty) :: Maybe (Value Gen))++findOrdInstance :: Instances -> Type -> Maybe (Value OrdInstance)+findOrdInstance insts ty = findInstance insts ty++findObserver :: Instances -> Type -> Maybe (Gen (Value Identity -> Value Ordy))+findObserver insts ty = do+  inst <- findInstance insts ty :: Maybe (Value WrappedObserveData)+  return $+    case unwrap inst of+      WrappedObserveData val `In` valueWrapper ->+        case unwrap val of+          -- This brings Arbitrary and Ord instances into scope+          ObserveData obs `In` outcomeWrapper -> do+            test <- arbitrary+            return $ \x ->+              let value = runIdentity (reunwrap valueWrapper x)+                  outcome = obs test value+              in wrap outcomeWrapper (Ordy outcome)++-- | Generate a random function. Should be in QuickCheck.+arbitraryFunction :: CoArbitrary a => (a -> Gen b) -> Gen (a -> b)+arbitraryFunction gen = promote (\x -> coarbitrary x (gen x))++-- | Evaluate a Haskell term in an environment.+evalHaskell :: Type -> Instances -> TestCase -> Term Constant -> Maybe (Value Ordy)+evalHaskell def insts (TestCase env obs) t = do+  let eval env t = evalTerm env (evalConstant insts) t+  Identity val `In` w <- unwrap <$> eval env (defaultTo def t)+  res <- obs (wrap w (Identity val))+  -- Don't allow partial results to enter the decision tree+  guard (withValue res (\(Ordy x) -> isJust (teaspoon (x == x))))+  return res++data Constant =+  Constant {+    con_name  :: String,+    con_style :: TermStyle,+    con_value :: Value Identity,+    con_type :: Type,+    con_constraints :: [Type],+    con_size :: Int,+    con_classify :: Classification Constant,+    con_is_hole :: Bool }++instance Eq Constant where+  x == y =+    con_name x == con_name y && typ (con_value x) == typ (con_value y)++instance Ord Constant where+  compare =+    comparing $ \con ->+      (typeArity (typ con), typ con, con_name con)++instance Background Constant++con :: Typeable a => String -> a -> Constant+con name val =+  constant' name (toValue (Identity val))++constant' :: String -> Value Identity -> Constant+constant' name val =+  Constant {+    con_name = name,+    con_style =+      case () of+        _ | name == "()" -> curried+          | take 1 name == "," -> fixedArity (length name+1) tupleStyle+          | take 2 name == "(," -> fixedArity (length name-1) tupleStyle+          | isOp name && typeArity (typ val) >= 2 -> infixStyle 5+          | isOp name -> prefix+          | otherwise -> curried,+    con_value = val,+    con_type = ty,+    con_constraints = constraints,+    con_size = 1,+    con_classify = Function,+    con_is_hole = False }+  where+    (constraints, ty) = splitConstrainedType (typ val)++isOp :: String -> Bool+isOp "[]" = False+isOp ('"':_) = False+isOp xs | all (== '.') xs = True+isOp xs = not (all isIdent xs)+  where+    isIdent x = isAlphaNum x || x == '\'' || x == '_' || x == '.'++-- Get selectors of a predicate+selectors :: Constant -> [Constant]+selectors con =+  case con_classify con of+    Predicate{..} -> clas_selectors+    _ -> []++-- Move the constraints of a constant back into the main type+unhideConstraint :: Constant -> Constant+unhideConstraint con =+  con {+    con_type = typ (con_value con),+    con_constraints = [] }++instance Typed Constant where+  typ = con_type+  otherTypesDL con =+    return (typ (con_value con)) `mplus`+    case con_classify con of+      Predicate{..} ->+        -- Don't call typesDL on clas_selectors because it in turn+        -- contains a reference to the predicate+        typesDL (map con_value clas_selectors) `mplus` typesDL clas_test_case `mplus` typesDL clas_true+      Selector{..} ->+        typesDL clas_pred `mplus` typesDL clas_test_case+      Function -> mzero+  typeSubst_ sub con =+    con { con_value = typeSubst_ sub (con_value con),+          con_type = typeSubst_ sub (con_type con),+          con_constraints = map (typeSubst_ sub) (con_constraints con),+          con_classify = fmap (typeSubst_ sub) (con_classify con) }++instance Pretty Constant where+  pPrint = text . con_name++instance PrettyTerm Constant where+  termStyle = con_style++instance Sized Constant where+  size = con_size++instance Predicate Constant where+  classify = con_classify++evalConstant :: Instances -> Constant -> Maybe (Value Identity)+evalConstant insts Constant{..} = foldM app con_value con_constraints+  where+    app val constraint = do+      dict <- findValue insts constraint+      return (apply val dict)++class Predicateable a where+  -- A test case for predicates of type a+  -- if `a ~ A -> B -> C -> Bool` we get `TestCase a ~ (A, (B, (C, ())))`+  --+  -- Some speedup should be possible by using unboxed tuples instead...+  type PredicateTestCase a+  type PredicateResult a+  uncrry :: a -> PredicateTestCase a -> PredicateResult a+  true :: proxy a -> Constant++instance Predicateable Bool where+  type PredicateTestCase Bool = ()+  type PredicateResult Bool = Bool+  uncrry = const+  true _ = con "True" True++instance forall a b. (Predicateable b, Typeable a) => Predicateable (a -> b) where+  type PredicateTestCase (a -> b) = (a, PredicateTestCase b)+  type PredicateResult (a -> b) = PredicateResult b+  uncrry f (a, b) = uncrry (f a) b+  true _ = true (Proxy :: Proxy b)++-- A more user-friendly type for PredicateTestCase.+type FriendlyPredicateTestCase a = Friendly (PredicateTestCase a)+class HasFriendly a where+  type Friendly a+  unfriendly :: Friendly a -> a+instance HasFriendly () where+  type Friendly () = ()+  unfriendly () = ()+instance HasFriendly (a, ()) where+  type Friendly (a, ()) = a+  unfriendly a = (a, ())+instance HasFriendly (a, (b, ())) where+  type Friendly (a, (b, ())) = (a, b)+  unfriendly (a, b) = (a, (b, ()))+instance HasFriendly (a, (b, (c, ()))) where+  type Friendly (a, (b, (c, ()))) = (a, b, c)+  unfriendly (a, b, c) = (a, (b, (c, ())))+instance HasFriendly (a, (b, (c, (d, ())))) where+  type Friendly (a, (b, (c, (d, ())))) = (a, b, c, d)+  unfriendly (a, b, c, d) = (a, (b, (c, (d, ()))))++data TestCaseWrapped (t :: Symbol) a = TestCaseWrapped { unTestCaseWrapped :: a }++unfriendlyPredicateGen :: forall a b. ( Predicateable a+                       , Typeable a+                       , Typeable b+                       , Typeable (PredicateTestCase a))+                       => String -> a -> (b -> Gen (PredicateTestCase a)) -> (Instances, Constant)+unfriendlyPredicateGen name pred gen =+  let+    -- The following doesn't compile on GHC 7.10:+    -- ty = typeRep (Proxy :: Proxy (TestCaseWrapped sym (PredicateTestCase a)))+    -- (where sym was created using someSymbolVal)+    -- So do it by hand instead:+    ty = addName (typeRep (Proxy :: Proxy (TestCaseWrapped SymA (PredicateTestCase a))))++    -- Replaces SymA with 'String name'+    -- (XXX: not correct if the type 'a' also contains SymA)+    addName :: forall a. Typed a => a -> a+    addName = typeSubst sub+      where+        sub x+          | Twee.build (Twee.var x) == typeRep (Proxy :: Proxy SymA) =+            Twee.builder (typeFromTyCon (String name))+          | otherwise = Twee.var x++    instances =+      mconcat $ map (valueInst . addName)+        [toValue (Identity inst1), toValue (Identity inst2)]++    inst1 :: b -> Gen (TestCaseWrapped SymA (PredicateTestCase a))+    inst1 x = TestCaseWrapped <$> gen x++    inst2 :: Names (TestCaseWrapped SymA (PredicateTestCase a))+    inst2 = Names [name ++ "_var"]++    conPred = (con name pred) { con_classify = Predicate conSels ty (Fun (true (Proxy :: Proxy a))) }+    conSels = [ (constant' (name ++ "_" ++ show i) (select (i + length (con_constraints conPred)))) { con_classify = Selector i conPred ty, con_size = 0 } | i <- [0..typeArity (typ conPred)-1] ]++    select i =+      fromJust (cast (arrowType [ty] (typeArgs (typeOf pred) !! i)) (unPoly (compose (sel i) unwrapV)))+      where+        compose f g = apply (apply cmpV f) g+        sel 0 = fstV+        sel n = compose (sel (n-1)) sndV+        fstV = toPolyValue (fst :: (A, B) -> A)+        sndV = toPolyValue (snd :: (A, B) -> B)+        cmpV = toPolyValue ((.) :: (B -> C) -> (A -> B) -> A -> C)+        unwrapV = toPolyValue (unTestCaseWrapped :: TestCaseWrapped SymA A -> A)+  in+    (instances, conPred)++-- | Declare a predicate with a given name and value.+-- The predicate should have type @... -> Bool@.+-- Uses an explicit generator.+predicateGen :: forall a. ( Predicateable a+             , Typeable a+             , Typeable (PredicateTestCase a)+             , HasFriendly (PredicateTestCase a))+             => String -> a -> (Gen (FriendlyPredicateTestCase a)) -> (Instances, Constant)+predicateGen name pred gen =+  unfriendlyPredicateGen name pred (\() -> unfriendly <$> gen)++-- | Declare a predicate with a given name and value.+-- The predicate should have type @... -> Bool@.+predicate :: forall a. ( Predicateable a+          , PredicateResult a ~ Bool+          , Typeable a+          , Typeable (PredicateTestCase a))+          => String -> a -> (Instances, Constant)+predicate name pred = unfriendlyPredicateGen name pred inst+  where+    inst :: Dict (Arbitrary (PredicateTestCase a)) -> Gen (PredicateTestCase a)+    inst Dict = arbitrary `suchThat` uncrry pred++-- | How QuickSpec should style equations.+data PrintStyle+  = ForHumans+  | ForQuickCheck+  deriving (Eq, Ord, Show, Read, Bounded, Enum)++data Config =+  Config {+    cfg_quickCheck :: QuickCheck.Config,+    cfg_twee :: Twee.Config,+    cfg_max_size :: Int,+    cfg_max_commutative_size :: Int,+    cfg_max_functions :: Int,+    cfg_instances :: Instances,+    -- This represents the constants for a series of runs of QuickSpec.+    -- Each index in cfg_constants represents one run of QuickSpec.+    -- head cfg_constants contains all the background functions.+    cfg_constants :: [[Constant]],+    cfg_default_to :: Type,+    cfg_infer_instance_types :: Bool,+    cfg_background :: [Prop (Term Constant)],+    cfg_print_filter :: Prop (Term Constant) -> Bool,+    cfg_print_style :: PrintStyle,+    cfg_check_consistency :: Bool+    }++lens_quickCheck = lens cfg_quickCheck (\x y -> y { cfg_quickCheck = x })+lens_twee = lens cfg_twee (\x y -> y { cfg_twee = x })+lens_max_size = lens cfg_max_size (\x y -> y { cfg_max_size = x })+lens_max_commutative_size = lens cfg_max_commutative_size (\x y -> y { cfg_max_commutative_size = x })+lens_max_functions = lens cfg_max_functions (\x y -> y { cfg_max_functions = x })+lens_instances = lens cfg_instances (\x y -> y { cfg_instances = x })+lens_constants = lens cfg_constants (\x y -> y { cfg_constants = x })+lens_default_to = lens cfg_default_to (\x y -> y { cfg_default_to = x })+lens_infer_instance_types = lens cfg_infer_instance_types (\x y -> y { cfg_infer_instance_types = x })+lens_background = lens cfg_background (\x y -> y { cfg_background = x })+lens_print_filter = lens cfg_print_filter (\x y -> y { cfg_print_filter = x })+lens_print_style = lens cfg_print_style (\x y -> y { cfg_print_style = x })+lens_check_consistency = lens cfg_check_consistency (\x y -> y { cfg_check_consistency = x })++defaultConfig :: Config+defaultConfig =+  Config {+    cfg_quickCheck = QuickCheck.Config { QuickCheck.cfg_num_tests = 1000, QuickCheck.cfg_max_test_size = 100, QuickCheck.cfg_fixed_seed = Nothing },+    cfg_twee = Twee.Config { Twee.cfg_max_term_size = minBound, Twee.cfg_max_cp_depth = maxBound },+    cfg_max_size = 7,+    cfg_max_commutative_size = 5,+    cfg_max_functions = maxBound,+    cfg_instances = mempty,+    cfg_constants = [],+    cfg_default_to = typeRep (Proxy :: Proxy Int),+    cfg_infer_instance_types = False,+    cfg_background = [],+    cfg_print_filter = \_ -> True,+    cfg_print_style = ForHumans,+    cfg_check_consistency = False }++-- Extra types for the universe that come from in-scope instances.+instanceTypes :: Instances -> Config -> [Type]+instanceTypes insts Config{..}+  | not cfg_infer_instance_types = []+  | otherwise =+    [ tv+    | cls <- dicts,+      inst <- groundInstances,+      sub <- maybeToList (matchType cls inst),+      (_, tv) <- Twee.substToList sub ]+  where+    dicts =+      concatMap con_constraints (concat cfg_constants) >>=+      maybeToList . getDictionary++    groundInstances :: [Type]+    groundInstances =+      [ dict+      | -- () :- dict+        Twee.App tc (Twee.Cons (Twee.App unit Twee.Empty) (Twee.Cons dict Twee.Empty)) <-+        map (typeRes . typ) (is_instances insts),+        Twee.fun_value tc == tyCon (Proxy :: Proxy (:-)),+        Twee.fun_value unit == tyCon (Proxy :: Proxy (() :: Constraint)),+        Twee.isGround dict ]++data Warnings =+  Warnings {+    warn_no_generator :: [Type],+    warn_no_observer :: [Type] }++warnings :: Universe -> Instances -> Config -> Warnings+warnings univ insts Config{..} =+  Warnings {+    warn_no_generator =+      [ ty | ty <- types, isNothing (findGenerator cfg_default_to insts ty) ],+    warn_no_observer =+      [ ty | ty <- types, isNothing (findObserver insts ty) ] }+  where+    -- Check after defaulting types to Int (or whatever it is)+    types =+      [ ty+      | ty <- defaultTo cfg_default_to . Set.toList . univ_types $ univ,+        isNothing (findInstance insts ty :: Maybe (Value NoWarnings)) ]++instance Pretty Warnings where+  pPrint Warnings{..} =+    vcat $+      [section genDoc warn_no_generator] +++      [section obsDoc warn_no_observer] +++      [text "" | warnings ]+    where+      warnings = not (null warn_no_generator) || not (null warn_no_observer)+      section _ [] = pPrintEmpty+      section doc xs =+        doc $$+        nest 2 (vcat (map pPrintType xs)) $$+        text ""++      genDoc =+        text "WARNING: The following types have no 'Arbitrary' instance declared." $$+        text "You will not get any variables of the following types:"++      obsDoc =+        text "WARNING: The following types have no 'Ord' or 'Observe' instance declared." $$+        text "You will not get any equations about the following types:"++quickSpec :: Config -> IO [Prop (Term Constant)]+quickSpec cfg@Config{..} = do+  let+    constantsOf f =+      usort (concatMap funs $+        [clas_true | Predicate{..} <- map classify (f cfg_constants)] +++        [clas_true (classify clas_pred) | Selector{..} <- map classify (f cfg_constants)]) +++      f cfg_constants ++ concatMap selectors (f cfg_constants)+    constants = constantsOf concat++    univ = conditionalsUniverse (instanceTypes instances cfg) constants+    instances = cfg_instances `mappend` baseInstances++    eval = evalHaskell cfg_default_to instances+    was_observed = isNothing . findOrdInstance instances  -- it was observed if there is no Ord instance directly in scope++    prettierProp funs norm = prettyDefinition funs . prettyAC norm . conditionalise+    prettiestProp funs norm = prettyProp (names instances) . prettierProp funs norm++    present funs prop = do+      norm <- normaliser+      let prop' = prettierProp funs norm prop+      when (not (hasBackgroundPredicates prop') && not (isBackgroundProp prop') && cfg_print_filter prop) $ do+        (n :: Int, props) <- get+        put (n+1, props)+        putLine $+          case cfg_print_style of+            ForHumans ->+              printf "%3d. %s" n $ show $+                prettiestProp funs norm prop <+> disambiguatePropType prop+            ForQuickCheck ->+              renderStyle (style {lineLength = 78}) $ nest 2 $+                prettyPropQC+                  cfg_default_to+                  was_observed+                  n+                  (names instances)+                  prop'+                  <+> disambiguatePropType prop++    hasBackgroundPredicates (_ :=>: t :=: u)+      | not (null [p | p <- funs t, isBackgroundPredicate p]),+        not (null [q | q <- funs u, isBackgroundPredicate q]) =+        True+    hasBackgroundPredicates _ = False+    isBackgroundPredicate p =+      p `elem` concat (take 1 cfg_constants) &&+      case classify p of+        Predicate{} -> True+        _ -> False++    isBackgroundProp p =+      not (null fs) && and [f `elem` concat (take 1 cfg_constants) | f <- fs]+      where+        fs = funs p++    -- XXX do this during testing+    constraintsOk = memo $ \con ->+      or [ and [ isJust (findValue instances (defaultTo cfg_default_to constraint)) | constraint <- con_constraints (typeSubst sub con) ]+         | ty <- Set.toList (univ_types univ),+           sub <- maybeToList (matchType (typeRes (typ con)) ty) ]++    enumerator cons =+      sortTerms measure $+      filterEnumerator (all constraintsOk . funs) $+      filterEnumerator (\t -> length (usort (funs t)) <= cfg_max_functions) $+      filterEnumerator (\t -> size t + length (conditions t) <= cfg_max_size) $+      enumerateConstants atomic `mappend` enumerateApplications+      where+        atomic = cons ++ [Var (V typeVar 0)]++    conditions t = usort [p | f <- funs t, Selector _ p _ <- [classify f]]++    use ty =+      ofValue (\(Use x) -> x) $ fromJust $+      (findInstance instances ty :: Maybe (Value Use))++    mainOf n f g = do+      unless (null (f cfg_constants)) $ do+        putLine $ show $ pPrintSignature+          (map (Fun . unhideConstraint) (f cfg_constants))+        putLine ""+      when (n > 0) $ do+        putText (prettyShow (warnings univ instances cfg))+        putLine "== Laws =="+        when (cfg_print_style == ForQuickCheck) $ do+          putLine "quickspec_laws :: [(String, Property)]"+          putLine "quickspec_laws ="+      let+        pres prop = do+          modify $ \(k, props) -> (k, prop:props)+          if n == 0 then return () else present (constantsOf f) prop+      QuickSpec.Internal.Explore.quickSpec pres (flip eval) cfg_max_size cfg_max_commutative_size use univ+        (enumerator (map Fun (constantsOf g)))+      when (n > 0) $ do+        when (cfg_print_style == ForQuickCheck) $ putLine "  ]"+        putLine ""++    main = do+      forM_ cfg_background $ \prop -> do+        add prop+      mapM_ round [0..rounds-1]+      where+        round n = mainOf n (concat . take 1 . drop n) (concat . take (n+1))+        rounds = length cfg_constants++    -- Used in checkConsistency. Generate a term to be used when a+    -- Twee proof contains a hole ("?"), i.e. a don't-care variable.+    hole ty = do+      -- It doesn't matter what the value of the variable is, so+      -- generate a single random value and use that.+      vgen <- findInstance instances ty :: Maybe (Value Gen)+      let runGen g = Identity (unGen g (mkQCGen 1234) 5)+      return $ Fun $ (constant' "hole" (mapValue runGen vgen)) { con_is_hole = True }++    -- Remove holes by replacing them with a fresh variable.+    removeHoles prop = mapTerm (flatMapFun f) prop+      where+        f con+          | con_is_hole con = Var (V (typ con) n)+          | otherwise = Fun con+        n = freeVar prop++    checkConsistency = do+      thms <- theorems hole+      let numThms = length thms+      norm <- normaliser++      forM_ (zip [1 :: Int ..] thms) $ \(i, thm) -> do+        putStatus (printf "checking laws for consistency: %d/%d" i numThms)+        res <- test (prop thm)+        case res of+          TestFailed testcase -> do+            forM_ (axiomsUsed thm) $ \(ax, insts) ->+              forM_ insts $ \inst -> do+                res <- retest testcase inst+                when (testResult res == TestFailed ()) $ do+                  modify (Map.insertWith Set.union (removeHoles ax) (Set.singleton (removeHoles inst)))+          _ -> return ()++      falseProps <- get+      forM_ (Map.toList falseProps) $ \(ax, insts) -> do+        putLine (printf "*** Law %s is false!" (prettyShow (prettiestProp constants norm ax)))+        putLine "False instances:"+        forM_ (Set.toList insts) $ \inst -> do+          putLine (printf "  %s is false" (prettyShow (prettiestProp constants norm inst)))+        putLine ""++  join $+    fmap withStdioTerminal $+    generate $+    QuickCheck.run cfg_quickCheck (arbitraryTestCase cfg_default_to instances) eval $+    Twee.run cfg_twee { Twee.cfg_max_term_size = Twee.cfg_max_term_size cfg_twee `max` cfg_max_size } $+    runConditionals constants $ do+      result <- fmap (reverse . snd) $ flip execStateT (1, []) main+      when cfg_check_consistency $ void $ execStateT checkConsistency Map.empty+      return result
+ src/QuickSpec/Internal/Haskell/Resolve.hs view
@@ -0,0 +1,119 @@+-- A data structure for resolving typeclass instances and similar at runtime.+--+-- Takes as input a set of functions ("instances"), and a type, and+-- tries to build a value of that type from the instances given.+--+-- For example, given the instances+--   ordList :: Dict (Arbitrary a) -> Dict (Arbitrary [a])+--   ordChar :: Dict (Arbitrary Char)+-- and the target type Dict (Arbitrary [Char]), it will produce the value+--   ordList ordChar :: Dict (Arbitrary [Char]).+--+-- The instances can in fact be arbitrary Haskell functions - though+-- their types must be such that the instance search will terminate.++{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-}+module QuickSpec.Internal.Haskell.Resolve(Instances(..), inst, valueInst, findInstance, findValue) where++import Twee.Base+import QuickSpec.Internal.Type+import Data.MemoUgly+import Data.Functor.Identity+import Data.Maybe+import Data.Proxy+import Control.Monad+#if !MIN_VERSION_base(4,9,0)+import Data.Semigroup(Semigroup(..))+#endif++-- A set of instances.+data Instances =+  Instances {+    -- The available instances.+    -- Each instance is a unary function; 'inst' sees to this.+    is_instances :: [Poly (Value Identity)],+    -- The resulting instance search function (memoised).+    is_find      :: Type -> [Value Identity] }++-- A smart constructor for Instances.+makeInstances :: [Poly (Value Identity)] -> Instances+makeInstances is = inst+  where+    inst = Instances is (memo (find_ inst . canonicaliseType))++instance Semigroup Instances where+  x <> y = makeInstances (is_instances x ++ is_instances y)+instance Monoid Instances where+  mempty = makeInstances []+  mappend = (<>)++-- Create a single instance.+inst :: Typeable a => a -> Instances+inst x = valueInst (toValue (Identity x))++valueInst :: Value Identity -> Instances+valueInst x = polyInst (poly x)+  where+    polyInst :: Poly (Value Identity) -> Instances+    polyInst x =+      -- Transform x into a single-argument function+      -- (see comment about is_instances).+      case typ x of+        -- A function of type a -> (b -> c) gets uncurried.+        App (F _ Arrow) (Cons _ (Cons (App (F _ Arrow) _) Empty)) ->+          polyInst (apply uncur x)+        App (F _ Arrow) _ ->+          makeInstances [x]+        -- A plain old value x (not a function) turns into \() -> x.+        _ ->+          makeInstances [apply delay x]+      where+        uncur = toPolyValue (uncurry :: (A -> B -> C) -> (A, B) -> C)+        delay = toPolyValue ((\x () -> x) :: A -> () -> A)++-- Construct a value of a particular type.+-- If the type is polymorphic, may return an instance of it.+findValue :: Instances -> Type -> Maybe (Value Identity)+findValue insts = listToMaybe . is_find insts . skolemiseTypeVars++-- Given a type a, construct a value of type f a.+-- If the type is polymorphic, may return an instance of it.+findInstance :: forall f. Typeable f => Instances -> Type -> Maybe (Value f)+findInstance insts ty =+  unwrapFunctor runIdentity <$> findValue insts ty'+  where+    ty' = typeRep (Proxy :: Proxy f) `applyType` ty++-- The unmemoised version of the search algorithm.+-- Knows how to apply unary functions, and also knows how to generate:+--   * The unit type ()+--   * Pairs (a, b) - search for a and then for b+-- These two are important because instValue encodes other instances+-- using them.+--+-- Invariant: the type of the returned value is an instance of the argument type.+find_ :: Instances -> Type -> [Value Identity]+find_ _ (App (F _ unit) Empty)+  | unit == tyCon (Proxy :: Proxy ()) =+    return (toValue (Identity ()))+find_ insts (App (F _ pair) (Cons ty1 (Cons ty2 Empty)))+  | pair == tyCon (Proxy :: Proxy (,)) = do+    x <- is_find insts ty1+    sub <- maybeToList (match ty1 (typ x))+    -- N.B.: subst sub ty2 because searching for x may have constrained y's type+    y <- is_find insts (subst sub ty2)+    sub <- maybeToList (match ty2 (typ y))+    return (pairValues (liftM2 (,)) (typeSubst sub x) y)+find_ insts ty = do+  -- Find a function whose result type unifies with ty.+  -- Rename it to avoid clashes with ty.+  fun <- fmap (polyRename ty) (is_instances insts)+  App (F _ Arrow) (Cons arg (Cons res Empty)) <- return (typ fun)+  sub <- maybeToList (unify ty res)+  fun <- return (typeSubst sub fun)+  arg <- return (typeSubst sub arg)+  -- Find an argument for that function and apply the function.+  val <- is_find insts arg+  sub <- maybeToList (match arg (typ val))+  return (apply (typeSubst sub fun) val)
+ src/QuickSpec/Internal/Parse.hs view
@@ -0,0 +1,60 @@+-- | Parsing strings into properties.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GADTs, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+module QuickSpec.Internal.Parse where++import Control.Monad+import Data.Char+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Term hiding (char)+import QuickSpec.Internal.Type+import qualified Data.Label as Label+import Text.ParserCombinators.ReadP++class Parse fun a where+  parse :: ReadP fun -> ReadP a++instance Parse fun Var where+  parse _ = do+    x <- satisfy isUpper+    xs <- munch isAlphaNum+    let name = x:xs+    -- Use Data.Label as an easy way to generate a variable number+    return (V typeVar (fromIntegral (Label.labelNum (Label.label name))))++instance (fun1 ~ fun, Apply (Term fun)) => Parse fun1 (Term fun) where+  parse pfun =+    parseApp <++ parseVar+    where+      parseVar = Var <$> parse pfun+      parseApp = do+        f <- pfun+        args <- parseArgs <++ return []+        return (unPoly (foldl apply (poly (Fun f)) (map poly args)))+      parseArgs = between (char '(') (char ')') (sepBy (parse pfun) (char ','))++instance (Parse fun a, Typed a) => Parse fun (Equation a) where+  parse pfun = do+    t <- parse pfun+    string "="+    u <- parse pfun+    -- Compute type unifier of t and u+    -- "maybe mzero return" injects Maybe into MonadPlus+    pt <- maybe mzero return (polyMgu (poly (typ t)) (poly (typ u)))+    t <- maybe mzero return (cast (unPoly pt) t)+    u <- maybe mzero return (cast (unPoly pt) u)+    return (t :=: u)++instance (Parse fun a, Typed a) => Parse fun (Prop a) where+  parse pfun = do+    lhs <- sepBy (parse pfun) (string "&")+    unless (null lhs) (void (string "=>"))+    rhs <- parse pfun+    return (lhs :=>: rhs)++parseProp :: (Parse fun a, Pretty a) => ReadP fun -> String -> a+parseProp pfun xs =+  case readP_to_S (parse pfun <* eof) (filter (not . isSpace) xs) of+    [(x, [])] -> x+    ps -> error ("parse': got result " ++ prettyShow ps ++ " while parsing " ++ xs)
+ src/QuickSpec/Internal/Prop.hs view
@@ -0,0 +1,150 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE DeriveGeneric, TypeFamilies, DeriveFunctor, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, TypeOperators, DeriveTraversable #-}+module QuickSpec.Internal.Prop where++import Data.Bool (bool)+import Control.Monad+import qualified Data.DList as DList+import Data.Ord+import QuickSpec.Internal.Type+import QuickSpec.Internal.Utils+import QuickSpec.Internal.Term hiding (first)+import GHC.Generics(Generic)+import qualified Data.Map.Strict as Map+import Control.Monad.Trans.State.Strict+import Data.List+import Control.Arrow (first)++data Prop a =+  (:=>:) {+    lhs :: [Equation a],+    rhs :: Equation a }+  deriving (Show, Generic, Functor, Traversable, Foldable)++instance Symbolic f a => Symbolic f (Prop a) where+  termsDL (lhs :=>: rhs) =+    termsDL rhs `mplus` termsDL lhs+  subst sub (lhs :=>: rhs) =+    subst sub lhs :=>: subst sub rhs++instance Ord a => Eq (Prop a) where+  x == y = x `compare` y == EQ+instance Ord a => Ord (Prop a) where+  compare = comparing (\p -> (usort (lhs p), rhs p))++infix 4 :=>:++literals :: Prop a -> [Equation a]+literals p = rhs p:lhs p++unitProp :: Equation a -> Prop a+unitProp p = [] :=>: p++mapFun :: (fun1 -> fun2) -> Prop (Term fun1) -> Prop (Term fun2)+mapFun f = fmap (fmap f)++mapTerm :: (Term fun1 -> Term fun2) -> Prop (Term fun1) -> Prop (Term fun2)+mapTerm f (lhs :=>: rhs) = map (both f) lhs :=>: both f rhs+  where+    both f (t :=: u) = f t :=: f u++instance Typed a => Typed (Prop a) where+  typ _ = typeOf True+  otherTypesDL p = DList.fromList (literals p) >>= typesDL+  typeSubst_ sub (lhs :=>: rhs) =+    map (typeSubst_ sub) lhs :=>: typeSubst_ sub rhs++instance Pretty a => Pretty (Prop a) where+  pPrint ([] :=>: rhs) = pPrint rhs+  pPrint p =+    hsep (punctuate (text " &") (map pPrint (lhs p))) <+> text "=>" <+> pPrint (rhs p)++data Equation a = a :=: a deriving (Show, Eq, Ord, Generic, Functor, Traversable, Foldable)++instance Symbolic f a => Symbolic f (Equation a) where+  termsDL (t :=: u) = termsDL t `mplus` termsDL u+  subst sub (t :=: u) = subst sub t :=: subst sub u++infix 5 :=:++instance Typed a => Typed (Equation a) where+  typ (t :=: _) = typ t+  otherTypesDL (t :=: u) = otherTypesDL t `mplus` typesDL u+  typeSubst_ sub (x :=: y) = typeSubst_ sub x :=: typeSubst_ sub y++instance Pretty a => Pretty (Equation a) where+  pPrintPrec _ _ (x :=: y)+    | isTrue x = pPrint y+    | isTrue y = pPrint x+    | otherwise = pPrint x <+> text "=" <+> pPrint y+    where+      -- XXX this is a hack+      isTrue x = show (pPrint x) == "True"++infix 4 ===+(===) :: a -> a -> Prop a+x === y = [] :=>: x :=: y++----------------------------------------------------------------------+-- Making properties look pretty (naming variables, etc.)+----------------------------------------------------------------------++prettyProp ::+  (Typed fun, Apply (Term fun), PrettyTerm fun) =>+  (Type -> [String]) -> Prop (Term fun) -> Doc+prettyProp cands = pPrint . snd . nameVars cands++prettyPropQC ::+  (Typed fun, Apply (Term fun), PrettyTerm fun) =>+  Type -> (Type -> Bool) -> Int -> (Type -> [String]) -> Prop (Term fun) -> Doc+prettyPropQC default_to was_observed nth cands x+  = hang (text first_char <+> text "(" <+> ((text $ show $ show $ pPrint law))) 2+  $ hang (hsep [text ",", text "property", text "$"]) 4+  $ hang ppr_binds 4+  $ (ppr_ctx <+> with_sig lhs lhs_type <+> eq_fn <+> pPrint rhs) <> text ")"+  where+    eq = "==="+    obs_eq = "=~="+    eq_fn = text $ bool eq obs_eq $ was_observed lhs_type+    lhs_type = typ lhs_for_type++    first_char =+      case nth of+        1 -> "["+        _ -> ","+    ppr_ctx =+      case length ctx of+        0 -> pPrintEmpty+        _ -> (hsep $ punctuate (text " &&") $ fmap (parens . pPrint) ctx) <+> text "==>"++    (_ :=>: (lhs_for_type :=: _)) = x+    (var_defs, law@(ctx :=>: (lhs :=: rhs))) = nameVars cands x+    with_sig expr ty = print_sig (pPrint expr) ty+    print_sig doc ty = parens $ doc <+> text "::" <+> pPrintType (defaultTo default_to ty)+    ppr_binds =+      case Map.size var_defs of+        0 -> pPrintEmpty+        _ -> (text "\\ " <> sep (fmap (uncurry print_sig) (fmap (first text) $ Map.assocs var_defs))) <+> text "->"+++data Named fun = Name String | Ordinary fun+instance Pretty fun => Pretty (Named fun) where+  pPrintPrec _ _ (Name name) = text name+  pPrintPrec l p (Ordinary fun) = pPrintPrec l p fun+instance PrettyTerm fun => PrettyTerm (Named fun) where+  termStyle Name{} = curried+  termStyle (Ordinary fun) = termStyle fun++nameVars :: (Type -> [String]) -> Prop (Term fun) -> (Map.Map String Type, Prop (Term (Named fun)))+nameVars cands p =+  (var_defs, subst (\x -> Map.findWithDefault undefined x sub) (fmap (fmap Ordinary) p))+  where+    sub = Map.fromList sub_map+    (sub_map, var_defs) = (runState (mapM assign (nub (vars p))) Map.empty)+    assign x = do+      s <- get+      let ty = typ x+          names = supply (cands ty)+          name = head (filter (`Map.notMember` s) names)+      modify (Map.insert name ty)+      return (x, Fun (Name name))
+ src/QuickSpec/Internal/Pruning.hs view
@@ -0,0 +1,95 @@+-- A type of pruners.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, DefaultSignatures, GADTs, TypeOperators, DeriveFunctor, DeriveTraversable #-}+module QuickSpec.Internal.Pruning where++import QuickSpec.Internal.Prop+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Type(Type)+import Twee.Pretty+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import Data.Maybe++data Theorem norm =+  Theorem {+    prop :: Prop norm,+    axiomsUsed :: [(Prop norm, [Prop norm])] }+  deriving (Functor, Foldable, Traversable)++instance Pretty norm => Pretty (Theorem norm) where+  pPrint thm =+    (text "prop =" <+> pPrint (prop thm)) $$+    (text "axioms used =" <+> pPrint (axiomsUsed thm))++class Monad m => MonadPruner term norm m | m -> term norm where+  normaliser :: m (term -> norm)+  add :: Prop term -> m Bool+  decodeNormalForm :: (Type -> Maybe term) -> norm -> m (Maybe term)+  normTheorems :: m [Theorem norm]++  default normaliser :: (MonadTrans t, MonadPruner term norm m', m ~ t m') => m (term -> norm)+  normaliser = lift normaliser++  default add :: (MonadTrans t, MonadPruner term norm m', m ~ t m') => Prop term -> m Bool+  add = lift . add++  default normTheorems :: (MonadTrans t, MonadPruner term' norm m', m ~ t m') => m [Theorem norm]+  normTheorems = lift normTheorems++  default decodeNormalForm :: (MonadTrans t, MonadPruner term norm m', m ~ t m') => (Type -> Maybe term) -> norm -> m (Maybe term)+  decodeNormalForm hole t = lift (decodeNormalForm hole t)++decodeTheorem :: MonadPruner term norm m => (Type -> Maybe term) -> Theorem norm -> m (Maybe (Theorem term))+decodeTheorem hole thm = elimMaybeThm <$> mapM (decodeNormalForm hole) thm+  where+    elimMaybeThm (Theorem prop axs) =+      case sequence prop of+        Nothing -> Nothing+        Just prop -> Just (Theorem prop (mapMaybe elimMaybeAx axs))+    elimMaybeAx (ax, insts) =+      case sequence ax of+        Nothing -> Nothing+        Just ax -> Just (ax, mapMaybe elimMaybeInst insts)+    elimMaybeInst = sequence++theorems :: MonadPruner term norm m => (Type -> Maybe term) -> m [Theorem term]+theorems hole = do+  thms <- normTheorems+  catMaybes <$> mapM (decodeTheorem hole) thms++instance MonadPruner term norm m => MonadPruner term norm (StateT s m)+instance MonadPruner term norm m => MonadPruner term norm (ReaderT r m)++normalise :: MonadPruner term norm m => term -> m norm+normalise t = do+  norm <- normaliser+  return (norm t)++newtype ReadOnlyPruner m a = ReadOnlyPruner { withReadOnlyPruner :: m a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term)++instance MonadTrans ReadOnlyPruner where+  lift = ReadOnlyPruner++instance MonadPruner term norm m => MonadPruner term norm (ReadOnlyPruner m) where+  normaliser = ReadOnlyPruner normaliser+  add _ = return True++newtype WatchPruner term m a = WatchPruner (StateT [Prop term] m a)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadTester testcase term)++instance MonadPruner term norm m => MonadPruner term norm (WatchPruner term m) where+  normaliser = lift normaliser+  add prop = do+    res <- lift (add prop)+    WatchPruner (modify (prop:))+    return res++watchPruner :: Monad m => WatchPruner term m a -> m (a, [Prop term])+watchPruner (WatchPruner mx) = do+  (x, props) <- runStateT mx []+  return (x, reverse props)+
+ src/QuickSpec/Internal/Pruning/Background.hs view
@@ -0,0 +1,46 @@+-- A pruning layer which automatically adds axioms about functions as they appear.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, UndecidableInstances, TypeOperators #-}+module QuickSpec.Internal.Pruning.Background where++import QuickSpec.Internal.Term+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Terminal+import qualified Data.Set as Set+import Data.Set(Set)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict hiding (State)++newtype Pruner fun m a =+  Pruner (StateT (Set fun) m a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTester testcase term, MonadTerminal)++class Background f where+  background :: f -> [Prop (Term f)]+  background _ = []++run :: Monad m => Pruner fun m a -> m a+run (Pruner x) =+  evalStateT x Set.empty++instance (Ord fun, Background fun, MonadPruner (Term fun) norm m) =>+  MonadPruner (Term fun) norm (Pruner fun m) where+  normaliser = lift normaliser+  add prop = do+    mapM_ addFunction (funs prop)+    lift (add prop)++addFunction :: (Ord fun, Background fun, MonadPruner (Term fun) norm m) => fun -> Pruner fun m ()+addFunction f = do+  funcs <- Pruner get+  unless (f `Set.member` funcs) $ do+    Pruner (put (Set.insert f funcs))+    mapM_ add (background f)++instance (Background fun1, Background fun2) => Background (fun1 :+: fun2) where+  background (Inl x) = map (fmap (fmap Inl)) (background x)+  background (Inr x) = map (fmap (fmap Inr)) (background x)
+ src/QuickSpec/Internal/Pruning/PartialApplication.hs view
@@ -0,0 +1,107 @@+-- Pruning support for partial application and the like.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, RecordWildCards, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, UndecidableInstances, DeriveFunctor #-}+module QuickSpec.Internal.Pruning.PartialApplication where++import QuickSpec.Internal.Term as Term+import QuickSpec.Internal.Type+import QuickSpec.Internal.Pruning.Background hiding (Pruner)+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Prop as Prop+import QuickSpec.Internal.Terminal+import QuickSpec.Internal.Testing+import Control.Monad.IO.Class+import Control.Monad.Trans.Class++data PartiallyApplied f =+    -- A partially-applied function symbol.+    -- The Int describes how many arguments the function expects.+    Partial f Int+    -- The ($) operator, for oversaturated applications.+    -- The type argument is the type of the first argument to ($).+  | Apply Type+  deriving (Eq, Ord, Functor)++instance Sized f => Sized (PartiallyApplied f) where+  size (Partial f _) = size f+  size (Apply _) = 1++instance Arity (PartiallyApplied f) where+  arity (Partial _ n) = n+  arity (Apply _) = 2++instance Pretty f => Pretty (PartiallyApplied f) where+  pPrint (Partial f n) = pPrint f <#> text "@" <#> pPrint n+  pPrint (Apply _) = text "$"++instance PrettyTerm f => PrettyTerm (PartiallyApplied f) where+  termStyle (Partial f _) = termStyle f+  termStyle (Apply _) = infixStyle 2++instance Typed f => Typed (PartiallyApplied f) where+  typ (Apply ty) = arrowType [ty] ty+  typ (Partial f _) = typ f+  otherTypesDL (Apply _) = mempty+  otherTypesDL (Partial f _) = otherTypesDL f+  typeSubst_ sub (Apply ty) = Apply (typeSubst_ sub ty)+  typeSubst_ sub (Partial f n) = Partial (typeSubst_ sub f) n++partial :: f -> Term (PartiallyApplied f)+partial f = Fun (Partial f 0)++total :: Arity f => f -> PartiallyApplied f+total f = Partial f (arity f)++smartApply ::+  Typed f => Term (PartiallyApplied f) -> Term (PartiallyApplied f) -> Term (PartiallyApplied f)+smartApply (Fun (Partial f n) :@: ts) u =+  Fun (Partial f (n+1)) :@: (ts ++ [u])+smartApply t u = simpleApply t u++simpleApply ::+  Typed f =>+  Term (PartiallyApplied f) -> Term (PartiallyApplied f) -> Term (PartiallyApplied f)+simpleApply t u =+  Fun (Apply (typ t)) :@: [t, u]++instance (Typed f, Background f) => Background (PartiallyApplied f) where+  background (Partial f _) =+    map (Prop.mapFun (\f -> Partial f arity)) (background f) +++    [ simpleApply (partial n) (vs !! n) === partial (n+1)+    | n <- [0..arity-1] ]+    where+      arity = typeArity (typ f)+      partial i =+        Fun (Partial f i) :@: take i vs+      vs = map Var (zipWith V (typeArgs (typ f)) [0..])+  background _ = []++newtype Pruner fun pruner a =+  Pruner { run :: pruner a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal)++instance MonadTrans (Pruner fun) where+  lift = Pruner++instance (PrettyTerm fun, Typed fun, MonadPruner (Term (PartiallyApplied fun)) norm pruner) => MonadPruner (Term fun) norm (Pruner fun pruner) where+  normaliser =+    Pruner $ do+      norm <- normaliser+      return $ \t ->+        norm . encode $ t++  add prop =+    Pruner $ do+      add (encode <$> canonicalise prop)++  decodeNormalForm hole t =+    Pruner $ do+      t <- decodeNormalForm (fmap (fmap (flip Partial 0)) . hole) t+      let f (Partial x _) = NotId x+          f (Apply _) = Id+      return $ t >>= eliminateId . Term.mapFun f++encode :: Typed fun => Term fun -> Term (PartiallyApplied fun)+encode (Var x) = Var x+encode (Fun f) = partial f+encode (t :$: u) = smartApply (encode t) (encode u)
+ src/QuickSpec/Internal/Pruning/Twee.hs view
@@ -0,0 +1,31 @@+-- A pruner that uses twee. Supports types and background axioms.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RecordWildCards, FlexibleContexts, FlexibleInstances, GADTs, PatternSynonyms, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-}+module QuickSpec.Internal.Pruning.Twee(Config(..), module QuickSpec.Internal.Pruning.Twee) where++import QuickSpec.Internal.Testing+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Term+import QuickSpec.Internal.Terminal+import qualified QuickSpec.Internal.Pruning.Types as Types+import QuickSpec.Internal.Pruning.Types(Tagged)+import qualified QuickSpec.Internal.Pruning.PartialApplication as PartialApplication+import QuickSpec.Internal.Pruning.PartialApplication(PartiallyApplied)+import qualified QuickSpec.Internal.Pruning.Background as Background+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import qualified QuickSpec.Internal.Pruning.UntypedTwee as Untyped+import QuickSpec.Internal.Pruning.UntypedTwee(Config(..))+import Data.Typeable++newtype Pruner fun m a =+  Pruner (PartialApplication.Pruner fun (Types.Pruner (PartiallyApplied fun) (Background.Pruner (Tagged (PartiallyApplied fun)) (Untyped.Pruner (Tagged (PartiallyApplied fun)) m))) a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term,+            MonadPruner (Term fun) (Untyped.Norm (Tagged (PartiallyApplied fun))), MonadTerminal)++instance MonadTrans (Pruner fun) where+  lift = Pruner . lift . lift . lift . lift++run :: (Sized fun, Typeable fun, Ord fun, Monad m) => Config -> Pruner fun m a -> m a+run config (Pruner x) =+  Untyped.run config (Background.run (Types.run (PartialApplication.run x)))
+ src/QuickSpec/Internal/Pruning/Types.hs view
@@ -0,0 +1,121 @@+-- Encode monomorphic types during pruning.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-}+module QuickSpec.Internal.Pruning.Types where++import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Pruning.Background(Background(..))+import QuickSpec.Internal.Testing+import QuickSpec.Internal.Term+import QuickSpec.Internal.Type+import QuickSpec.Internal.Prop hiding (mapFun)+import QuickSpec.Internal.Terminal+import Control.Monad.IO.Class+import Control.Monad.Trans.Class++data Tagged fun =+    Func fun+  | Tag Type+  deriving (Eq, Ord, Show, Typeable)++instance Arity fun => Arity (Tagged fun) where+  arity (Func f) = arity f+  arity (Tag _) = 1++instance Sized fun => Sized (Tagged fun) where+  size (Func f) = size f+  size (Tag _) = 0++instance Pretty fun => Pretty (Tagged fun) where+  pPrint (Func f) = pPrint f+  pPrint (Tag ty) = text "tag[" <#> pPrint ty <#> text "]"++instance PrettyTerm fun => PrettyTerm (Tagged fun) where+  termStyle (Func f) = termStyle f+  termStyle (Tag _) = uncurried++instance Typed fun => Typed (Tagged fun) where+  typ (Func f) = typ f+  typ (Tag ty) = arrowType [ty] ty++  typeSubst_ sub (Func f) = Func (typeSubst_ sub f)+  typeSubst_ sub (Tag ty) = Tag (typeSubst_ sub ty)++instance EqualsBonus (Tagged fun) where++type TypedTerm fun = Term fun+type UntypedTerm fun = Term (Tagged fun)++newtype Pruner fun pruner a =+  Pruner { run :: pruner a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal)++instance MonadTrans (Pruner fun) where+  lift = Pruner++instance (PrettyTerm fun, Typed fun, MonadPruner (UntypedTerm fun) norm pruner) => MonadPruner (TypedTerm fun) norm (Pruner fun pruner) where+  normaliser =+    Pruner $ do+      norm <- normaliser :: pruner (UntypedTerm fun -> norm)++      -- Note that we don't call addFunction on the functions in the term.+      -- This is because doing so might be expensive, as adding typing+      -- axioms starts the completion algorithm.+      -- This is OK because in encode, we tag all functions and variables+      -- with their types (i.e. we can fall back to the naive type encoding).+      return $ \t ->+        norm . encode $ t++  add prop = lift (add (encode <$> canonicalise prop))++  decodeNormalForm hole t =+    Pruner $ do+      t <- decodeNormalForm (fmap (fmap Func) . hole) t+      let f (Func x) = NotId x+          f (Tag _) = Id+      return $ t >>= eliminateId . mapFun f++instance (Typed fun, Arity fun, Background fun) => Background (Tagged fun) where+  background = typingAxioms++-- Compute the typing axioms for a function or type tag.+typingAxioms :: (Typed fun, Arity fun, Background fun) =>+  Tagged fun -> [Prop (UntypedTerm fun)]+typingAxioms (Tag ty) =+  [tag ty (tag ty x) === tag ty x]+  where+    x = Var (V ty 0)+typingAxioms (Func func) =+  [tag res t === t] +++  [tagArg i ty === t | (i, ty) <- zip [0..] args] +++  map (fmap encode) (background func)+  where+    f = Fun (Func func)+    xs = take n (map (Var . V typeVar) [0..])++    ty = typ func+    -- Use arity rather than typeArity, so that we can support+    -- partially-applied functions+    n = arity func+    args = take n (typeArgs ty)+    res = typeDrop n ty++    t = f :@: xs++    tagArg i ty =+      f :@:+        (take i xs +++         [tag ty (xs !! i)] +++         drop (i+1) xs)++tag :: Type -> UntypedTerm fun -> UntypedTerm fun+tag ty t = Fun (Tag ty) :$: t++encode :: Typed fun => TypedTerm fun -> UntypedTerm fun+-- We always add type tags; see comment in normaliseMono.+-- In the common case, twee will immediately remove these surplus type tags+-- by rewriting using the typing axioms.+encode (Var x) = tag (typ x) (Var x)+encode (Fun f :@: ts) =+  tag (typeDrop (length ts) (typ f)) (Fun (Func f) :@: map encode ts)+encode _ = error "partial application"
+ src/QuickSpec/Internal/Pruning/UntypedTwee.hs view
@@ -0,0 +1,195 @@+-- A pruner that uses twee. Does not respect types.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RecordWildCards, FlexibleContexts, FlexibleInstances, GADTs, PatternSynonyms, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-}+module QuickSpec.Internal.Pruning.UntypedTwee where++import QuickSpec.Internal.Testing+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Prop+import QuickSpec.Internal.Term+import QuickSpec.Internal.Type+import Data.Lens.Light+import qualified Twee+import qualified Twee.Equation as Twee+import qualified Twee.KBO as KBO+import qualified Twee.Base as Twee+import Twee hiding (Config(..))+import Twee.Rule hiding (normalForms)+import Twee.Proof hiding (Config, defaultConfig)+import Twee.Base(Ordered(..), Labelled)+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict hiding (State)+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import QuickSpec.Internal.Terminal+import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map.Strict as Map+import qualified Data.IntMap as IntMap+import Control.Monad++data Config =+  Config {+    cfg_max_term_size :: Int,+    cfg_max_cp_depth :: Int }++lens_max_term_size = lens cfg_max_term_size (\x y -> y { cfg_max_term_size = x })+lens_max_cp_depth = lens cfg_max_cp_depth (\x y -> y { cfg_max_cp_depth = x })++data Extended fun = Minimal | Skolem Twee.Var | Function fun+  deriving (Eq, Ord, Typeable)++instance (Ord fun, Typeable fun) => Labelled (Extended fun)++instance Sized fun => Sized (Extended fun) where+  size (Function f) = size f+  size _ = 1++instance KBO.Sized (Extended fun) where+  size _ = 1++instance Arity fun => Arity (Extended fun) where+  arity (Function f) = arity f+  arity (Skolem _) = 0+  arity Minimal = 0++instance (Ord fun, Typeable fun) => Twee.Minimal (Extended fun) where+  minimal = Twee.fun Minimal++instance EqualsBonus (Extended fun)++instance (Ord fun, Typeable fun, Pretty fun) => Pretty (Extended fun) where+  pPrintPrec l p (Function f) = pPrintPrec l p f+  pPrintPrec _ _ Minimal = text "?"+  pPrintPrec _ _ (Skolem (Twee.V x)) = text ("sk" ++ show x)++instance (Ord fun, Typeable fun, PrettyTerm fun) => PrettyTerm (Extended fun) where+  termStyle (Function f) = termStyle f+  termStyle _ = curried++instance (Sized fun, Pretty fun, PrettyTerm fun, Ord fun, Typeable fun, Arity fun, EqualsBonus fun) => Ordered (Extended fun) where+  lessEq = KBO.lessEq+  lessIn = KBO.lessIn+  lessEqSkolem = KBO.lessEqSkolem++newtype Pruner fun m a =+  Pruner (ReaderT (Twee.Config (Extended fun)) (StateT (State (Extended fun)) m) a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal)++instance MonadTrans (Pruner fun) where+  lift = Pruner . lift . lift++run :: (Typeable fun, Ord fun, Sized fun, Monad m) => Config -> Pruner fun m a -> m a+run Config{..} (Pruner x) =+  evalStateT (runReaderT x config) (initialState config)+  where+    config =+      defaultConfig {+        Twee.cfg_accept_term = Just (\t -> size t <= cfg_max_term_size),+        Twee.cfg_max_cp_depth = cfg_max_cp_depth }++instance (Labelled fun, Sized fun) => Sized (Twee.Term fun) where+  size (Twee.Var _) = 1+  size (Twee.App f ts) =+    size (Twee.fun_value f) + sum (map size (Twee.unpack ts))++instance KBO.Weighted (Extended fun) where+  argWeight _ = 1++type Norm fun = Twee.Term (Extended fun)++instance (Ord fun, Typed fun, Typeable fun, Arity fun, PrettyTerm fun, EqualsBonus fun, Sized fun, Monad m) =>+  MonadPruner (Term fun) (Norm fun) (Pruner fun m) where+  normaliser = Pruner $ do+    state <- lift get+    return $ \t ->+      let u = normaliseTwee state t in+      u+      -- traceShow (text "normalise:" <+> pPrint t <+> text "->" <+> pPrint u) u++  add ([] :=>: t :=: u) = Pruner $ do+    state <- lift get+    config <- ask+    let (t' :=: u') = canonicalise (t :=: u)+    if not (null (Set.intersection (normalFormsTwee state t') (normalFormsTwee state u'))) then+      return False+    else do+      lift (put $! addTwee config t u state)+      return True++  add _ =+    return True+    --error "twee pruner doesn't support non-unit equalities"++  decodeNormalForm hole t = return (decode t (error "ambiguously-typed term"))+    where+      decode (Twee.Var (Twee.V n)) ty =+        Just (Var (V ty n))+      decode (Twee.App (Twee.F _ Minimal) Twee.Empty) ty =+        hole ty+      decode (Twee.App (Twee.F _ (Skolem (Twee.V n))) Twee.Empty) ty =+        Just (Var (V ty n))+      decode (Twee.App (Twee.F _ (Function f)) ts) _ =+        (Fun f :@:) <$> zipWithM decode (Twee.unpack ts) args+        where+          args = typeArgs (typ f)+      decode _ _ = error "ill-typed term"++  normTheorems = Pruner $ do+    state <- lift get+    let actives = IntMap.elems (Twee.st_active_set state)+    let+      toTheorem active =+        Theorem+          (toProp (equation proof))+          (map toAxiom . Map.toList . groundAxiomsAndSubsts $ deriv)+        where+          proof = Twee.active_proof active+          deriv = derivation proof+          toProp (t Twee.:=: u) = [] :=>: t :=: u+          toAxiom (ax, subs) = (toProp eqn, map toProp [Twee.subst sub eqn | sub <- Set.toList subs])+            where+              eqn = axiom_eqn ax++    return (map toTheorem actives)++normaliseTwee :: (Ord fun, Typeable fun, Arity fun, PrettyTerm fun, EqualsBonus fun, Sized fun) =>+  State (Extended fun) -> Term fun -> Norm fun+normaliseTwee state t =+  result u (normaliseTerm state u)+  where+    u = simplifyTerm state (skolemise t)++normalFormsTwee :: (Ord fun, Typeable fun, Arity fun, PrettyTerm fun, EqualsBonus fun, Sized fun) =>+  State (Extended fun) -> Term fun -> Set (Norm fun)+normalFormsTwee state t =+  Set.fromList . Map.elems $ Map.mapWithKey result (normalForms state (skolemise t))++addTwee :: (Ord fun, Typeable fun, Arity fun, PrettyTerm fun, EqualsBonus fun, Sized fun) =>+  Twee.Config (Extended fun) -> Term fun -> Term fun -> State (Extended fun) -> State (Extended fun)+addTwee config t u state =+  interreduce config $+  completePure config $+    addAxiom config state axiom+  where+    axiom = Axiom 0 (prettyShow (t :=: u)) (toTwee t Twee.:=: toTwee u)++toTwee :: (Ord f, Typeable f) =>+  Term f -> Twee.Term (Extended f)+toTwee = Twee.build . tt+  where+    tt (Var (V _ x)) =+      Twee.var (Twee.V x)+    tt (Fun f :@: ts) =+      Twee.app (Twee.fun (Function f)) (map tt ts)+    tt _ = error "partially applied term"++skolemise :: (Ord f, Typeable f) =>+  Term f -> Twee.Term (Extended f)+skolemise = Twee.build . sk+  where+    sk (Var (V _ x)) =+      Twee.con (Twee.fun (Skolem (Twee.V x)))+    sk (Fun f :@: ts) =+      Twee.app (Twee.fun (Function f)) (map sk ts)+    sk _ = error "partially applied term"
+ src/QuickSpec/Internal/Term.hs view
@@ -0,0 +1,314 @@+-- | This module is internal to QuickSpec.+--+-- Typed terms and operations on them.+{-# LANGUAGE PatternSynonyms, ViewPatterns, TypeSynonymInstances, FlexibleInstances, TypeFamilies, ConstraintKinds, DeriveGeneric, DeriveAnyClass, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, TypeOperators, DeriveFunctor, FlexibleContexts, DeriveTraversable #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+module QuickSpec.Internal.Term(module QuickSpec.Internal.Term, module Twee.Base, module Twee.Pretty) where++import QuickSpec.Internal.Type+import QuickSpec.Internal.Utils+import Control.Monad+import GHC.Generics(Generic)+import Test.QuickCheck(CoArbitrary(..))+import Data.DList(DList)+import qualified Data.DList as DList+import Twee.Base(Pretty(..), PrettyTerm(..), TermStyle(..), EqualsBonus, prettyPrint)+import Twee.Pretty+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import Data.List+import Data.Ord+import Data.Maybe++-- | A typed term.+data Term f = Var {-# UNPACK #-} !Var | Fun !f | !(Term f) :$: !(Term f)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++-- | A variable, which has a type and a number.+data Var = V { var_ty :: !Type, var_id :: {-# UNPACK #-} !Int }+  deriving (Eq, Ord, Show, Generic)++instance CoArbitrary Var where+  coarbitrary = coarbitrary . var_id++instance Typed Var where+  typ x = var_ty x+  otherTypesDL _ = mzero+  typeSubst_ sub (V ty x) = V (typeSubst_ sub ty) x++match :: Eq f => Term f -> Term f -> Maybe (Map Var (Term f))+match (Var x) t = Just (Map.singleton x t)+match (Fun f) (Fun g)+  | f == g = Just Map.empty+  | otherwise = Nothing+match (f :$: x) (g :$: y) = do+  m1 <- match f g+  m2 <- match x y+  guard (and [t == u | (t, u) <- Map.elems (Map.intersectionWith (,) m1 m2)])+  return (Map.union m1 m2)++unify :: Eq f => Term f -> Term f -> Maybe (Map Var (Term f))+unify t u = loop Map.empty [(t, u)]+  where+    loop sub [] = Just sub+    loop sub ((Fun f, Fun g):xs)+      | f == g = loop sub xs+    loop sub ((f :$: x, g :$: y):xs) =+      loop sub ((f, g):(x, y):xs)+    loop sub ((Var x, t):xs)+      | t == Var x = loop sub xs+      | x `elem` vars t = Nothing+      | otherwise =+        loop+          (Map.insert x t (fmap (replace x t) sub))+          [(replace x t u, replace x t v) | (u, v) <- xs]+    loop sub ((t, Var x):xs) = loop sub ((Var x, t):xs)++    replace x t (Var y) | x == y = t+    replace _ _ t = t++-- | A class for things that contain terms.+class Symbolic f a | a -> f where+  -- | A different list of all terms contained in the thing.+  termsDL :: a -> DList (Term f)+  -- | Apply a substitution to all terms in the thing.+  subst :: (Var -> Term f) -> a -> a++instance Symbolic f (Term f) where+  termsDL = return+  subst sub (Var x) = sub x+  subst _ (Fun x) = Fun x+  subst sub (t :$: u) = subst sub t :$: subst sub u++instance Symbolic f a => Symbolic f [a] where+  termsDL = msum . map termsDL+  subst sub = map (subst sub)++class Sized a where+  size :: a -> Int++instance Sized f => Sized (Term f) where+  size (Var _) = 1+  size (Fun f) = size f+  size (t :$: u) =+    size t + size u ++    -- Penalise applied function variables, because they can be used+    -- to build many many terms without any constants at all+    case t of+      Var _ -> 1+      _ -> 0++instance Pretty Var where+  pPrint x = parens $ text "X" <#> pPrint (var_id x+1) <+> text "::" <+> pPrint (var_ty x)+  --pPrint x = text "X" <#> pPrint (var_id x+1)++instance PrettyTerm f => Pretty (Term f) where+  pPrintPrec l p (Var x :@: ts) =+    pPrintTerm curried l p (pPrint x) ts+  pPrintPrec l p (Fun f :@: ts) =+    pPrintTerm (termStyle f) l p (pPrint f) ts++-- | All terms contained in a `Symbolic`.+terms :: Symbolic f a => a -> [Term f]+terms = DList.toList . termsDL++-- | All function symbols appearing in a `Symbolic`, in order of appearance,+-- with duplicates included.+funs :: Symbolic f a => a -> [f]+funs x = [ f | t <- terms x, Fun f <- subterms t ]++-- | All variables appearing in a `Symbolic`, in order of appearance,+-- with duplicates included.+vars :: Symbolic f a => a -> [Var]+vars x = [ v | t <- terms x, Var v <- subterms t ]++-- | Decompose a term into a head and a list of arguments.+pattern f :@: ts <- (getApp -> (f, ts)) where+  f :@: ts = foldl (:$:) f ts++getApp :: Term f -> (Term f, [Term f])+getApp (t :$: u) = (f, ts ++ [u])+  where+    (f, ts) = getApp t+getApp t = (t, [])++-- | Compute the number of a variable which does /not/ appear in the `Symbolic`.+freeVar :: Symbolic f a => a -> Int+freeVar x = maximum (0:map (succ . var_id) (vars x))++-- | Count how many times a given function symbol occurs.+occ :: (Eq f, Symbolic f a) => f -> a -> Int+occ x t = length (filter (== x) (funs t))++-- | Count how many times a given variable occurs.+occVar :: Symbolic f a => Var -> a -> Int+occVar x t = length (filter (== x) (vars t))++-- | Map a function over variables.+mapVar :: (Var -> Var) -> Term f -> Term f+mapVar f (Var x) = Var (f x)+mapVar _ (Fun x) = Fun x+mapVar f (t :$: u) = mapVar f t :$: mapVar f u++-- | Map a function over function symbols.+mapFun :: (f -> g) -> Term f -> Term g+mapFun _ (Var x) = Var x+mapFun f (Fun x) = Fun (f x)+mapFun f (t :$: u) = mapFun f t :$: mapFun f u++-- | Map a function over function symbols.+flatMapFun :: (f -> Term g) -> Term f -> Term g+flatMapFun _ (Var x) = Var x+flatMapFun f (Fun x) = f x+flatMapFun f (t :$: u) =+  flatMapFun f t :$: flatMapFun f u++-- | A type representing functions which may be the identity.+data OrId f = Id | NotId f++-- | Eliminate the identity function from a term.+eliminateId :: Term (OrId f) -> Maybe (Term f)+eliminateId t = do+  t <- elim t+  case t of+    Id -> Nothing+    NotId t -> Just t+  where+    elim :: Term (OrId f) -> Maybe (OrId (Term f))+    elim (Var x) = Just (NotId (Var x))+    elim (Fun (NotId f)) = Just (NotId (Fun f))+    elim (Fun Id) = Just Id+    elim (t :$: u) = do+      t <- elim t+      u <- elim u+      case (t, u) of+        (Id, _) -> Just u+        (NotId _, Id) -> Nothing+        (NotId t, NotId u) -> Just (NotId (t :$: u))++-- | Find all subterms of a term. Includes the term itself.+subterms :: Term f -> [Term f]+subterms t = t:properSubterms t++-- | Find all subterms of a term. Does not include the term itself.+properSubterms :: Term f -> [Term f]+properSubterms (t :$: u) = subterms t ++ subterms u+properSubterms _ = []++subtermsFO :: Term f -> [Term f]+subtermsFO t = t:properSubtermsFO t++properSubtermsFO :: Term f -> [Term f]+properSubtermsFO (_f :@: ts) = concatMap subtermsFO ts+properSubtermsFO _ = []++-- | Renames variables so that they appear in a canonical order.+-- Also makes sure that variables of different types have different numbers.+canonicalise :: Symbolic fun a => a -> a+canonicalise t = subst (\x -> Map.findWithDefault undefined x sub) t+  where+    sub =+      Map.fromList+        [(x, Var (V ty n))+        | (x@(V ty _), n) <- zip (nub (vars t)) [0..]]++-- | Evaluate a term, given a valuation for variables and function symbols.+evalTerm :: (Typed fun, Apply a, Monad m) => (Var -> m a) -> (fun -> m a) -> Term fun -> m a+evalTerm var fun = eval+  where+    eval (Var x) = var x+    eval (Fun f) = fun f+    eval (t :$: u) = liftM2 apply (eval t) (eval u)++instance Typed f => Typed (Term f) where+  typ (Var x) = typ x+  typ (Fun f) = typ f+  typ (t :$: _) = typeDrop 1 (typ t)++  otherTypesDL (Var _) = mempty+  otherTypesDL (Fun f) = typesDL f+  otherTypesDL (t :$: u) = typesDL t `mplus` typesDL u++  typeSubst_ sub = tsub+    where+      tsub (Var x) = Var (typeSubst_ sub x)+      tsub (Fun f) = Fun (typeSubst_ sub f)+      tsub (t :$: u) =+        typeSubst_ sub t :$: typeSubst_ sub u++instance (PrettyTerm f, Typed f) => Apply (Term f) where+  tryApply t u = do+    tryApply (typ t) (typ u)+    return (t :$: u)++depth :: Term f -> Int+depth Var{} = 1+depth Fun{} = 1+depth (t :$: u) = depth t `max` (1+depth u)++-- | A standard term ordering - size, skeleton, generality.+-- Satisfies the property:+-- if measure (schema t) < measure (schema u) then t < u.+type Measure f = (Int, Int, Int, Int, MeasureFuns f, Int, [Var])+-- | Compute the term ordering for a term.+measure :: (Sized f, Typed f) => Term f -> Measure f+measure t =+  (depth t, size t, missing t, -length (vars t), MeasureFuns (skel t),+   -length (usort (vars t)), vars t)+  where+    skel (Var (V ty _)) = Var (V ty 0)+    skel (Fun f) = Fun f+    skel (t :$: u) = skel t :$: skel u+    -- Prefer fully-applied terms to partially-applied ones.+    -- This function counts how many unsaturated function applications+    -- occur in a term.+    missing (Fun f :@: ts) =+      typeArity (typ f) - length ts + sum (map missing ts)+    missing (Var _ :@: ts) =+      sum (map missing ts)++-- | A helper for `Measure`.+newtype MeasureFuns f = MeasureFuns (Term f)+instance Ord f => Eq (MeasureFuns f) where+  t == u = compare t u == EQ+instance Ord f => Ord (MeasureFuns f) where+  compare (MeasureFuns t) (MeasureFuns u) = compareFuns t u++-- | A helper for `Measure`.+compareFuns :: Ord f => Term f -> Term f -> Ordering+compareFuns (f :@: ts) (g :@: us) =+  compareHead f g `mappend` comparing (map MeasureFuns) ts us+  where+    compareHead (Var x) (Var y) = compare x y+    compareHead (Var _) _ = LT+    compareHead _ (Var _) = GT+    compareHead (Fun f) (Fun g) = compare f g+    compareHead _ _ = error "viewApp"++----------------------------------------------------------------------+-- * Data types a la carte-ish.+----------------------------------------------------------------------++-- | A sum type. Intended to be used to build the type of function+-- symbols. Comes with instances that are useful for QuickSpec.+data a :+: b = Inl a | Inr b deriving (Eq, Ord)++instance (Sized fun1, Sized fun2) => Sized (fun1 :+: fun2) where+  size (Inl x) = size x+  size (Inr x) = size x++instance (Typed fun1, Typed fun2) => Typed (fun1 :+: fun2) where+  typ (Inl x) = typ x+  typ (Inr x) = typ x+  otherTypesDL (Inl x) = otherTypesDL x+  otherTypesDL (Inr x) = otherTypesDL x+  typeSubst_ sub (Inl x) = Inl (typeSubst_ sub x)+  typeSubst_ sub (Inr x) = Inr (typeSubst_ sub x)++instance (Pretty fun1, Pretty fun2) => Pretty (fun1 :+: fun2) where+  pPrintPrec l p (Inl x) = pPrintPrec l p x+  pPrintPrec l p (Inr x) = pPrintPrec l p x++instance (PrettyTerm fun1, PrettyTerm fun2) => PrettyTerm (fun1 :+: fun2) where+  termStyle (Inl x) = termStyle x+  termStyle (Inr x) = termStyle x
+ src/QuickSpec/Internal/Terminal.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures, GADTs, TypeOperators #-}+module QuickSpec.Internal.Terminal where++import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import qualified Test.QuickCheck.Text as Text++class Monad m => MonadTerminal m where+  putText :: String -> m ()+  putLine :: String -> m ()+  putTemp :: String -> m ()++  default putText :: (MonadTrans t, MonadTerminal m', m ~ t m') => String -> m ()+  putText = lift . putText++  default putLine :: (MonadTrans t, MonadTerminal m', m ~ t m') => String -> m ()+  putLine = lift . putLine++  default putTemp :: (MonadTrans t, MonadTerminal m', m ~ t m') => String -> m ()+  putTemp = lift . putTemp++instance MonadTerminal m => MonadTerminal (StateT s m)+instance MonadTerminal m => MonadTerminal (ReaderT r m)++putStatus :: MonadTerminal m => String -> m ()+putStatus str = putTemp ("[" ++ str ++ "...]")++clearStatus :: MonadTerminal m => m ()+clearStatus = putTemp ""++withStatus :: MonadTerminal m => String -> m a -> m a+withStatus str mx = putStatus str *> mx <* clearStatus++newtype Terminal a = Terminal (ReaderT Text.Terminal IO a)+  deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTerminal Terminal where+  putText str = Terminal $ do+    term <- ask+    liftIO $ Text.putPart term str++  putLine str = Terminal $ do+    term <- ask+    liftIO $ Text.putLine term str++  putTemp str = Terminal $ do+    term <- ask+    liftIO $ Text.putTemp term str++withNullTerminal :: Terminal a -> IO a+withNullTerminal (Terminal mx) =+  Text.withNullTerminal (runReaderT mx)++withStdioTerminal :: Terminal a -> IO a+withStdioTerminal (Terminal mx) =+  Text.withStdioTerminal (runReaderT mx)
+ src/QuickSpec/Internal/Testing.hs view
@@ -0,0 +1,40 @@+-- A type of test case generators.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FunctionalDependencies, DefaultSignatures, GADTs, FlexibleInstances, UndecidableInstances, TypeOperators, DeriveFunctor #-}+module QuickSpec.Internal.Testing where++import QuickSpec.Internal.Prop+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader++data TestResult testcase =+    TestPassed+  | TestFailed testcase+  | Untestable+  deriving (Functor, Eq)++testResult :: TestResult testcase -> TestResult ()+testResult = fmap (const ())++testAnd :: TestResult testcase -> TestResult testcase -> TestResult testcase+TestPassed `testAnd` x = x+x `testAnd` _ = x++testImplies :: TestResult testcase -> TestResult testcase -> TestResult testcase+TestPassed `testImplies` x = x+TestFailed _ `testImplies` _ = TestPassed+Untestable `testImplies` _ = Untestable++class Monad m => MonadTester testcase term m | m -> testcase term where+  test :: Prop term -> m (TestResult testcase)+  retest :: testcase -> Prop term -> m (TestResult testcase)++  default test :: (MonadTrans t, MonadTester testcase term m', m ~ t m') => Prop term -> m (TestResult testcase)+  test = lift . test++  default retest :: (MonadTrans t, MonadTester testcase term m', m ~ t m') => testcase -> Prop term -> m (TestResult testcase)+  retest tc = lift . retest tc++instance MonadTester testcase term m => MonadTester testcase term (StateT s m)+instance MonadTester testcase term m => MonadTester testcase term (ReaderT r m)
+ src/QuickSpec/Internal/Testing/DecisionTree.hs view
@@ -0,0 +1,103 @@+-- Decision trees for testing terms for equality.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RecordWildCards #-}+module QuickSpec.Internal.Testing.DecisionTree where++import qualified Data.Map as Map+import Data.Map(Map)++data DecisionTree testcase result term =+  DecisionTree {+    -- A function for evaluating terms on test cases.+    dt_evaluate :: term -> testcase -> Maybe result,+    -- The set of test cases gathered so far.+    dt_test_cases :: [testcase],+    -- The tree itself.+    dt_tree :: !(Maybe (InnerTree result term)) }++data InnerTree result term =+    TestCase !(Map result (InnerTree result term))+  | Singleton !term++data Result testcase result term =+    Distinct (DecisionTree testcase result term)+  | EqualTo term++-- Make a new decision tree.+empty :: (term -> testcase -> Maybe result) -> DecisionTree testcase result term+empty eval =+  DecisionTree {+    dt_evaluate = eval,+    dt_test_cases = [],+    dt_tree = Nothing }++-- Add a new test case to a decision tree.+addTestCase ::+  testcase -> DecisionTree testcase result term ->+  DecisionTree testcase result term+addTestCase tc dt@DecisionTree{..} =+  dt{dt_test_cases = dt_test_cases ++ [tc]}++-- Insert a value into a decision tree.+insert :: Ord result =>+  term -> DecisionTree testcase result term ->+  Result testcase result term+insert x dt@DecisionTree{dt_tree = Nothing, ..} =+  Distinct dt{dt_tree = Just (Singleton x)}+insert x dt@DecisionTree{dt_tree = Just dt_tree, ..} =+  aux k dt_test_cases dt_tree+  where+    k tree = dt{dt_tree = Just tree}+    aux _ [] (Singleton y) = EqualTo y+    aux k (t:ts) (Singleton y) =+      case dt_evaluate y t of+        Nothing ->+          -- y is untestable, so we can evict it from the tree+          Distinct (k (Singleton x))+        Just val ->+          aux k (t:ts) $+            TestCase (Map.singleton val (Singleton y)) +    aux k (t:ts) (TestCase res) =+      case dt_evaluate x t of+        Nothing ->+          Distinct (k (TestCase res))+        Just val ->+          let+            k' tree = k (TestCase (Map.insert val tree res))+          in case Map.lookup val res of+            Nothing ->+              Distinct (k' (Singleton x))+            Just tree ->+              aux k' ts tree+    aux _ [] (TestCase _) =+      error "unexpected node in decision tree"++data Statistics =+  Statistics {+    -- Total number of terms in the decision tree+    stat_num_terms :: !Int,+    -- Total number of tests executed+    stat_num_tests :: !Int,+    -- Number of distinct test cases used+    stat_num_test_cases :: !Int }+  deriving (Eq, Show)++statistics :: DecisionTree testcase result term -> Statistics+statistics DecisionTree{dt_tree = Nothing} =+  Statistics 0 0 0+statistics DecisionTree{dt_tree = Just dt_tree, ..} =+  Statistics {+    stat_num_terms = x,+    stat_num_tests = y,+    stat_num_test_cases = length dt_test_cases }+  where+    (x, y) = stat dt_tree++    -- Returns (number of terms, number of tests)+    stat Singleton{} = (1, 0)+    -- To calculate the number of test cases, note that each term+    -- under res executed one test case on the way through this node.+    stat (TestCase res) =+      (sum (map fst ss), sum [ x + y | (x, y) <- ss ])+      where+        ss = map stat (Map.elems res)
+ src/QuickSpec/Internal/Testing/QuickCheck.hs view
@@ -0,0 +1,101 @@+-- Testing conjectures using QuickCheck.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+module QuickSpec.Internal.Testing.QuickCheck where++import QuickSpec.Internal.Testing+import QuickSpec.Internal.Pruning+import QuickSpec.Internal.Prop+import Test.QuickCheck+import Test.QuickCheck.Gen+import Test.QuickCheck.Random+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.List+import System.Random hiding (uniform)+import QuickSpec.Internal.Terminal+import Data.Lens.Light++data Config =+  Config {+    cfg_num_tests :: Int,+    cfg_max_test_size :: Int,+    cfg_fixed_seed :: Maybe QCGen}+  deriving Show++lens_num_tests = lens cfg_num_tests (\x y -> y { cfg_num_tests = x })+lens_max_test_size = lens cfg_max_test_size (\x y -> y { cfg_max_test_size = x })+lens_fixed_seed = lens cfg_fixed_seed (\x y -> y { cfg_fixed_seed = x })++data Environment testcase term result =+  Environment {+    env_config :: Config,+    env_tests :: [testcase],+    env_eval :: testcase -> term -> Maybe result }++newtype Tester testcase term result m a =+  Tester (ReaderT (Environment testcase term result) m a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadTerminal, MonadPruner term' res')++instance MonadTrans (Tester testcase term result) where+  lift = Tester . lift++run ::+  Config -> Gen testcase -> (testcase -> term -> Maybe result) ->+  Tester testcase term result m a -> Gen (m a)+run config@Config{..} gen eval (Tester x) = do+  seed <- maybe arbitrary return cfg_fixed_seed+  let+    seeds = unfoldr (Just . split) seed+    n = fromIntegral (ceiling (fromIntegral cfg_num_tests * (1 - zeroProportion)))+    zeroes = cfg_num_tests - n+    k = max 1 cfg_max_test_size+    bias = 3+    -- Run this proportion of tests of size 0.+    zeroProportion = 0.01+    -- Bias tests towards smaller sizes.+    -- We do this by distributing the cube of the size uniformly.+    sizes =+      replicate zeroes 0 +++      (reverse $ map (k -) $+       map (truncate . (** (1/fromInteger bias)) . fromIntegral) $+       uniform (toInteger n) (toInteger k^bias))+    tests = zipWith (unGen gen) seeds sizes+  return $ runReaderT x+    Environment {+      env_config = config,+      env_tests = tests,+      env_eval = eval }++-- uniform n k: generate a list of n integers which are distributed evenly between 0 and k-1.+uniform :: Integer -> Integer -> [Integer]+uniform n k =+  -- n `div` k: divide evenly as far as possible.+  concat [replicate (fromIntegral (n `div` k)) i | i <- [0..k-1]] +++  -- The leftovers get distributed at equal intervals.+  [i * k `div` leftovers | i <- [0..leftovers-1]]+  where+    leftovers = n `mod` k++instance (Monad m, Eq result) => MonadTester testcase term (Tester testcase term result m) where+  test prop =+    Tester $ do+      env@Environment{..} <- ask+      return $! foldr testAnd TestPassed (map (quickCheckTest env prop) env_tests)+  retest testcase prop =+    Tester $ do+      env@Environment{..} <- ask+      return $! quickCheckTest env prop testcase++quickCheckTest :: Eq result =>+  Environment testcase term result -> Prop term -> testcase -> TestResult testcase+quickCheckTest Environment{env_config = Config{..}, ..} (lhs :=>: rhs) testcase =+  foldr testAnd (testEq rhs) (map testEq lhs)+  where+    testEq (t :=: u) =+      case (env_eval testcase t, env_eval testcase u) of+        (Just t, Just u)+          | t == u -> TestPassed+          | otherwise -> TestFailed testcase+        _ -> Untestable
+ src/QuickSpec/Internal/Type.hs view
@@ -0,0 +1,573 @@+-- | This module is internal to QuickSpec.+--+-- Polymorphic types and dynamic values.+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, FlexibleInstances, GeneralizedNewtypeDeriving, Rank2Types, ExistentialQuantification, PolyKinds, TypeFamilies, FlexibleContexts, StandaloneDeriving, PatternGuards, MultiParamTypeClasses, ConstraintKinds, DataKinds, GADTs, TypeOperators #-}+-- To avoid a warning about TyVarNumber's constructor being unused:+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+module QuickSpec.Internal.Type(+  -- * Types+  Typeable,+  Arity(..),+  Type, TyCon(..), tyCon, fromTyCon, A, B, C, D, E, ClassA, ClassB, ClassC, ClassD, ClassE, ClassF, SymA, typeVar, isTypeVar,+  typeOf, typeRep, typeFromTyCon, applyType, fromTypeRep,+  arrowType, isArrowType, unpackArrow, typeArgs, typeRes, typeDrop, typeArity,+  isDictionary, getDictionary, splitConstrainedType, dictArity, pPrintType,+  -- * Things that have types+  Typed(..), typeSubst, typesDL, tyVars, cast, matchType,+  TypeView(..),+  Apply(..), apply, canApply,+  oneTypeVar, defaultTo, skolemiseTypeVars,+  -- * Polymorphic types+  canonicaliseType,+  Poly, toPolyValue, poly, unPoly, polyTyp, polyRename, polyApply, polyPair, polyList, polyMgu, polyFunctionMgu,+  -- * Dynamic values+  Value, toValue, fromValue, valueType,+  unwrap, Unwrapped(..), Wrapper(..),+  mapValue, forValue, ofValue, withValue, pairValues, wrapFunctor, unwrapFunctor, bringFunctor) where++import Control.Monad+import Data.DList(DList)+import Data.Maybe+import qualified Data.Typeable as Ty+import Data.Typeable(Typeable)+import GHC.Exts(Any)+import Test.QuickCheck+import Unsafe.Coerce+import Data.Constraint+import Twee.Base+import Data.Proxy+import Data.List hiding (singleton)+import Data.Char+import Data.Functor.Identity++-- | A (possibly polymorphic) type.+type Type = Term TyCon++-- | A type constructor.+data TyCon =+    -- | The function type constructor @(->)@.+    Arrow+    -- | An ordinary Haskell type constructor.+  | TyCon Ty.TyCon+    -- | A string. Can be used to represent miscellaneous types that do not+    -- really exist in Haskell.+  | String String+  deriving (Eq, Ord, Show, Typeable)++instance Labelled TyCon++instance Pretty TyCon where+  pPrint Arrow = text "->"+  pPrint (String x) = text x+  pPrint (TyCon x) = text (show x)+instance PrettyTerm TyCon where+  termStyle Arrow =+    fixedArity 2 $+    TermStyle $ \l p d [x, y] ->+      maybeParens (p > 8) $+        pPrintPrec l 9 x <+> d <+>+        pPrintPrec l 0 y++  termStyle (String _) = curried++  termStyle (TyCon con)+    | con == listTyCon =+      fixedArity 1 $+      TermStyle $ \l _ _ [x] -> brackets (pPrintPrec l 0 x)+    | show con == "()" || show con == "(%%)" =+      fixedArity 0 tupleStyle -- by analogy with case below+    | take 2 (show con) == "(," ||+      take 3 (show con) == "(%," =+      fixedArity (1+length (filter (== ',') (show con))) tupleStyle+    | isAlphaNum (head (show con)) = curried+    | otherwise = infixStyle 5++-- Type and class variables.+newtype A = A Any deriving Typeable+newtype B = B Any deriving Typeable+newtype C = C Any deriving Typeable+newtype D = D Any deriving Typeable+newtype E = E Any deriving Typeable++class ClassA+deriving instance Typeable ClassA+class ClassB+deriving instance Typeable ClassB+class ClassC+deriving instance Typeable ClassC+class ClassD+deriving instance Typeable ClassD+class ClassE+deriving instance Typeable ClassE+class ClassF+deriving instance Typeable ClassF++-- | A polymorphic type of kind Symbol.+type SymA = "__polymorphic_symbol__"++-- | All type variables that are defined in this module.+typeVars :: [Ty.TypeRep]+typeVars =+  [Ty.typeRep (Proxy :: Proxy A),+   Ty.typeRep (Proxy :: Proxy B),+   Ty.typeRep (Proxy :: Proxy C),+   Ty.typeRep (Proxy :: Proxy D),+   Ty.typeRep (Proxy :: Proxy E),+   Ty.typeRep (Proxy :: Proxy ClassA),+   Ty.typeRep (Proxy :: Proxy ClassB),+   Ty.typeRep (Proxy :: Proxy ClassC),+   Ty.typeRep (Proxy :: Proxy ClassD),+   Ty.typeRep (Proxy :: Proxy ClassE),+   Ty.typeRep (Proxy :: Proxy ClassF),+   Ty.typeRep (Proxy :: Proxy SymA)]++-- | A type variable.+typeVar :: Type+typeVar = typeRep (Proxy :: Proxy A)++-- | Check if a type is a type variable.+isTypeVar :: Type -> Bool+isTypeVar = isVar++-- | Construct a type from a `Typeable`.+typeOf :: Typeable a => a -> Type+typeOf x = fromTypeRep (Ty.typeOf x)++-- | Construct a type from a `Typeable`.+typeRep :: Typeable (a :: k) => proxy a -> Type+typeRep x = fromTypeRep (Ty.typeRep x)++-- | Turn a `TyCon` into a type.+typeFromTyCon :: TyCon -> Type+typeFromTyCon tc = build (con (fun tc))++-- | Function application for type constructors.+--+-- For example, @applyType (typeRep (Proxy :: Proxy [])) (typeRep (Proxy :: Proxy Int)) == typeRep (Proxy :: Proxy [Int])@.+applyType :: Type -> Type -> Type+applyType (App f tys) ty = build (app f (unpack tys ++ [ty]))+applyType _ _ = error "tried to apply type variable"++-- | Construct a function type.+arrowType :: [Type] -> Type -> Type+arrowType [] res = res+arrowType (arg:args) res =+  build (app (fun Arrow) [arg, arrowType args res])++-- | Is a given type a function type?+isArrowType :: Type -> Bool+isArrowType = isJust . unpackArrow++-- | Decompose a function type into (argument, result).+--+-- For multiple-argument functions, unpacks one argument.+unpackArrow :: Type -> Maybe (Type, Type)+unpackArrow (App (F _ Arrow) (Cons t (Cons u Empty))) =+  Just (t, u)+unpackArrow _ =+  Nothing++-- | The arguments of a function type.+typeArgs :: Type -> [Type]+typeArgs (App (F _ Arrow) (Cons arg (Cons res Empty))) =+  arg:typeArgs res+typeArgs _ = []++-- | The result of a function type.+typeRes :: Type -> Type+typeRes (App (F _ Arrow) (Cons _ (Cons res Empty))) =+  typeRes res+typeRes ty = ty++-- | Given the type of a function, returns the type of applying that function to+-- @n@ arguments. Crashes if the type does not have enough arguments.+typeDrop :: Int -> Type -> Type+typeDrop 0 ty = ty+typeDrop n (App (F _ Arrow) (Cons _ (Cons ty Empty))) =+  typeDrop (n-1) ty+typeDrop _ _ =+  error "typeDrop on non-function type"++-- | How many arguments does a function take?+typeArity :: Type -> Int+typeArity = length . typeArgs++-- | Unify all type variables in a type.+oneTypeVar :: Typed a => a -> a+oneTypeVar = typeSubst (const (var (V 0)))++-- | Replace all type variables with a particular type.+defaultTo :: Typed a => Type -> a -> a+defaultTo def = typeSubst (const def)++-- | Make a type ground by replacing all type variables+-- with Skolem constants.+skolemiseTypeVars :: Typed a => a -> a+skolemiseTypeVars = typeSubst (const aTy)+  where+    aTy = build (con (fun (tyCon (Proxy :: Proxy A))))++-- | Construct a type from a `Ty.TypeRep`.+fromTypeRep :: Ty.TypeRep -> Type+fromTypeRep ty+  | Just n <- elemIndex ty typeVars =+      build (var (V n))+  | otherwise =+    let (tyCon, tys) = Ty.splitTyConApp ty in+    build (app (fun (fromTyCon tyCon)) (map fromTypeRep tys))++-- | Construct a `TyCon` type from a "Data.Typeable" `Ty.TyCon`.+fromTyCon :: Ty.TyCon -> TyCon+fromTyCon ty+  | ty == arrowTyCon = Arrow+  | otherwise = TyCon ty++-- | Some built-in type consructors.+arrowTyCon, commaTyCon, listTyCon, dictTyCon :: Ty.TyCon+arrowTyCon = mkCon (Proxy :: Proxy (->))+commaTyCon = mkCon (Proxy :: Proxy (,))+listTyCon  = mkCon (Proxy :: Proxy [])+dictTyCon  = mkCon (Proxy :: Proxy Dict)++mkCon :: Typeable a => proxy a -> Ty.TyCon+mkCon = fst . Ty.splitTyConApp . Ty.typeRep++-- | Get the outermost `TyCon` of a `Typeable`.+tyCon :: Typeable a => proxy a -> TyCon+tyCon = fromTyCon . mkCon++-- | Check if a type is of the form @`Dict` c@, and if so, return @c@.+getDictionary :: Type -> Maybe Type+getDictionary (App (F _ (TyCon dict)) (Cons ty Empty))+  | dict == dictTyCon = Just ty+getDictionary _ = Nothing++-- | Check if a type is of the form @`Dict` c@.+isDictionary :: Type -> Bool+isDictionary = isJust . getDictionary++-- | Count how many dictionary arguments a type has.+dictArity :: Type -> Int+dictArity = length . takeWhile isDictionary . typeArgs++-- | Split a type into constraints and normal type.+splitConstrainedType :: Type -> ([Type], Type)+splitConstrainedType ty =+  (dicts, arrowType rest (typeRes ty))+  where+    (dicts, rest) = splitAt (dictArity ty) (typeArgs ty)++-- CoArbitrary instances.+instance CoArbitrary Type where+  coarbitrary = coarbitrary . singleton+instance CoArbitrary (TermList TyCon) where+  coarbitrary Empty = variant 0+  coarbitrary ConsSym{hd = Var (V x), rest = ts} =+    variant 1 . coarbitrary x . coarbitrary ts+  coarbitrary ConsSym{hd = App f _, rest = ts} =+    variant 2 . coarbitrary (fun_id f) . coarbitrary ts++-- | Pretty-print a type. Differs from the `Pretty` instance by printing type+-- variables in lowercase.+pPrintType :: Type -> Doc+pPrintType = ppr . typeSubst (\(V x) -> build (con (fun (String (as !! x))))) . canonicalise+  where+    as = supply [[x] | x <- ['a'..'z']]+    -- Print dictionary arguments specially+    ppr ty+      | Just (dict, res) <- unpackArrow ty,+        Just constraint <- getDictionary dict =+      pPrint constraint <+> text "=>" <+> ppr res+    ppr ty = pPrint ty++-- | A class for things that have a type.+class Typed a where+  -- | The type.+  typ :: a -> Type+  -- | Types that appear elsewhere in the `Typed`, for example, types of subterms.+  -- Should return everything which is affected by `typeSubst`.+  otherTypesDL :: a -> DList Type+  otherTypesDL _ = mzero+  -- | Substitute for all type variables.+  typeSubst_ :: (Var -> Builder TyCon) -> a -> a++-- | Substitute for all type variables in a `Typed`.+{-# INLINE typeSubst #-}+typeSubst :: (Typed a, Substitution s, SubstFun s ~ TyCon) => s -> a -> a+typeSubst s x = typeSubst_ (evalSubst s) x++-- | A wrapper for using the `Twee.Base.Symbolic` machinery on types.+newtype TypeView a = TypeView { unTypeView :: a }+instance Typed a => Symbolic (TypeView a) where+  type ConstantOf (TypeView a) = TyCon+  termsDL = fmap singleton . typesDL . unTypeView+  subst_ sub = TypeView . typeSubst_ sub . unTypeView+instance Typed a => Has (TypeView a) Type where+  the = typ . unTypeView++-- | All types that occur in a `Typed`.+typesDL :: Typed a => a -> DList Type+typesDL ty = return (typ ty) `mplus` otherTypesDL ty++-- | All type variables that occur in a `Typed`.+tyVars :: Typed a => a -> [Var]+tyVars = vars . TypeView++-- | Cast a `Typed` to a target type.+-- Succeeds if the target type is an instance of the current type.+cast :: Typed a => Type -> a -> Maybe a+cast ty x = do+  s <- match (typ x) ty+  return (typeSubst s x)++-- | Check if the second argument is an instance of the first argument.+matchType :: Type -> Type -> Maybe (Subst TyCon)+matchType = match++-- | Typed things that support function application.+class Typed a => Apply a where+  -- | Apply a function to its argument.+  --+  -- For most instances of `Typed`, the type of the argument must be exactly+  -- equal to the function's argument type. If you want unification to happen,+  -- use the `Typed` instance of `Poly`.+  tryApply :: a -> a -> Maybe a++-- | Apply a function to its argument, crashing on failure.+--+-- For most instances of `Typed`, the type of the argument must be exactly+-- equal to the function's argument type. If you want unification to happen,+-- use the `Typed` instance of `Poly`.+infixl `apply`+apply :: Apply a => a -> a -> a+apply f x =+  case tryApply f x of+    Nothing ->+      error $+        "apply: ill-typed term: can't apply " +++        prettyShow (typ f) ++ " to " ++ prettyShow (typ x)+    Just y -> y++-- | Check if a function can be applied to its argument.+canApply :: Apply a => a -> a -> Bool+canApply f x = isJust (tryApply f x)++-- Instances.+instance Typed Type where+  typ = id+  typeSubst_ = subst++instance Apply Type where+  tryApply (App (F _ Arrow) (Cons arg (Cons res Empty))) t+    | t == arg = Just res+  tryApply _ _ = Nothing++instance (Typed a, Typed b) => Typed (a, b) where+  typ (x, y) = build (app (fun (TyCon commaTyCon)) [typ x, typ y])+  otherTypesDL (x, y) = otherTypesDL x `mplus` otherTypesDL y+  typeSubst_ f (x, y) = (typeSubst_ f x, typeSubst_ f y)++instance (Typed a, Typed b) => Typed (Either a b) where+  typ (Left x)  = typ x+  typ (Right x) = typ x+  otherTypesDL (Left x)  = otherTypesDL x+  otherTypesDL (Right x) = otherTypesDL x+  typeSubst_ sub (Left x)  = Left  (typeSubst_ sub x)+  typeSubst_ sub (Right x) = Right (typeSubst_ sub x)++instance Typed a => Typed [a] where+  typ [] = typeOf ()+  typ (x:_) = typ x+  otherTypesDL [] = mzero+  otherTypesDL (x:xs) = otherTypesDL x `mplus` msum (map typesDL xs)+  typeSubst_ f xs = map (typeSubst_ f) xs++-- | Represents a forall-quantifier over all the type variables in a type.+-- Wrapping a term in @Poly@ normalises the type by alpha-renaming+-- type variables canonically.+--+-- The `Apply` instance for `Poly` does unification to handle applying a+-- polymorphic function.+newtype Poly a = Poly { unPoly :: a }+  deriving (Eq, Ord, Show, Pretty, Typeable)++-- | Build a `Poly`.+poly :: Typed a => a -> Poly a+poly x = Poly (canonicaliseType x)++-- | Alpha-rename type variables in a canonical way.+canonicaliseType :: Typed a => a -> a+canonicaliseType = unTypeView . canonicalise . TypeView++-- | Get the polymorphic type of a polymorphic value.+polyTyp :: Typed a => Poly a -> Poly Type+polyTyp (Poly x) = Poly (typ x)++-- | Rename the type variables of the second argument so that they don't overlap+-- with those of the first argument.+polyRename :: (Typed a, Typed b) => a -> Poly b -> b+polyRename x (Poly y) =+  unTypeView (renameAvoiding (TypeView x) (TypeView y))++-- | Rename the type variables of both arguments so that they don't overlap.+polyApply :: (Typed a, Typed b, Typed c) => (a -> b -> c) -> Poly a -> Poly b -> Poly c+polyApply f (Poly x) y = poly (f x (polyRename x y))++-- | Rename the type variables of both arguments so that they don't overlap.+polyPair :: (Typed a, Typed b) => Poly a -> Poly b -> Poly (a, b)+polyPair = polyApply (,)++-- | Rename the type variables of all arguments so that they don't overlap.+polyList :: Typed a => [Poly a] -> Poly [a]+polyList [] = poly []+polyList (x:xs) = polyApply (:) x (polyList xs)++-- | Find the most general unifier of two types.+polyMgu :: Poly Type -> Poly Type -> Maybe (Poly Type)+polyMgu ty1 ty2 = do+  let (ty1', ty2') = unPoly (polyPair ty1 ty2)+  sub <- unify ty1' ty2'+  return (poly (typeSubst sub ty1'))++polyFunctionMgu :: Apply a => Poly a -> Poly a -> Maybe (Poly (a, a))+polyFunctionMgu f x = do+  let (f', (x', resType)) = unPoly (polyPair f (polyPair x (poly (build (var (V 0))))))+  s <- unify (typ f') (arrowType [typ x'] resType)+  return (poly (typeSubst s (f', x')))++instance Typed a => Typed (Poly a) where+  typ = typ . unPoly+  otherTypesDL = otherTypesDL . unPoly+  typeSubst_ f (Poly x) = poly (typeSubst_ f x)++instance Apply a => Apply (Poly a) where+  tryApply f x = do+    (f', x') <- unPoly <$> polyFunctionMgu f x+    fmap poly (tryApply f' x')++-- | Convert an ordinary value to a dynamic value.+toPolyValue :: (Applicative f, Typeable a) => a -> Poly (Value f)+toPolyValue = poly . toValue . pure++-- | Dynamic values inside an applicative functor.+--+-- For example, a value of type @Value Maybe@ represents a @Maybe something@.+data Value f =+  Value {+    valueType :: Type,+    value :: f Any }++instance Show (Value f) where+  show x = "<<" ++ prettyShow (typ x) ++ ">>"++fromAny :: f Any -> f a+fromAny = unsafeCoerce++toAny :: f a -> f Any+toAny = unsafeCoerce++-- | Construct a `Value`.+toValue :: forall f (a :: *). Typeable a => f a -> Value f+toValue x = Value (typeRep (Proxy :: Proxy a)) (toAny x)++-- | Deconstruct a `Value`.+fromValue :: forall f (a :: *). Typeable a => Value f -> Maybe (f a)+fromValue x = do+  guard (typ x == typeRep (Proxy :: Proxy a))+  return (fromAny (value x))++instance Typed (Value f) where+  typ = valueType+  typeSubst_ f (Value ty x) = Value (typeSubst_ f ty) x+instance Applicative f => Apply (Value f) where+  tryApply f x = do+    ty <- tryApply (typ f) (typ x)+    return (Value ty (fromAny (value f) <*> value x))++-- | Unwrap a value to get at the thing inside, with an existential type.+unwrap :: Value f -> Unwrapped f+unwrap x =+  value x `In`+    Wrapper+      (\y -> Value (typ x) y)+      (\y ->+        if typ x == typ y+        then fromAny (value y)+        else error "non-matching types")++-- | The unwrapped value. Consists of the value itself (with an existential+-- type) and functions to wrap it up again.+data Unwrapped f where+  In :: f a -> Wrapper a -> Unwrapped f++-- | Functions for re-wrapping an `Unwrapped` value.+data Wrapper a =+  Wrapper {+    -- | Wrap up a value which has the same existential type as this one.+    wrap :: forall g. g a -> Value g,+    -- | Unwrap a value which has the same existential type as this one.+    reunwrap :: forall g. Value g -> g a }++-- | Apply a polymorphic function to a `Value`.+mapValue :: (forall a. f a -> g a) -> Value f -> Value g+mapValue f v =+  case unwrap v of+    x `In` w -> wrap w (f x)++-- | Apply a polymorphic function to a `Value`.+forValue :: Value f -> (forall a. f a -> g a) -> Value g+forValue x f = mapValue f x++-- | Apply a polymorphic function that returns a non-`Value` result to a `Value`.+ofValue :: (forall a. f a -> b) -> Value f -> b+ofValue f v =+  case unwrap v of+    x `In` _ -> f x++-- | Apply a polymorphic function that returns a non-`Value` result to a `Value`.+withValue :: Value f -> (forall a. f a -> b) -> b+withValue x f = ofValue f x++-- | Apply a polymorphic function to a pair of `Value`s.+pairValues :: forall f g. Typeable g => (forall a b. f a -> f b -> f (g a b)) -> Value f -> Value f -> Value f+pairValues f x y =+  ty `seq`+  Value {+    valueType = ty,+    value = toAny (f (value x) (value y)) }+  where+    ty = typeRep (Proxy :: Proxy g) `applyType` typ x `applyType` typ y++wrapFunctor :: forall f g h. Typeable h => (forall a. f a -> g (h a)) -> Value f -> Value g+wrapFunctor f x =+  ty `seq`+  Value {+    valueType = ty,+    value = toAny (f (value x)) }+  where+    ty = typeRep (Proxy :: Proxy h) `applyType` valueType x++unwrapFunctor :: forall f g h. Typeable g => (forall a. f (g a) -> h a) -> Value f -> Value h+unwrapFunctor f x =+  case typ x of+    App _ tys | tys@(_:_) <- unpack tys ->+      case ty `applyType` last tys == typ x of+        True ->+          Value {+            valueType = last tys,+            value = f (fromAny (value x)) }+        False ->+          error "non-matching types"+    _ -> error "value of type f a had wrong type"+  where+    ty = typeRep (Proxy :: Proxy g)++bringFunctor :: Functor f => Value f -> f (Value Identity)+bringFunctor val =+  case unwrap val of+    x `In` w ->+      fmap (wrap w . Identity) x++class Arity f where+  -- | Measure the arity.+  arity :: f -> Int
+ src/QuickSpec/Internal/Utils.hs view
@@ -0,0 +1,138 @@+-- | Miscellaneous utility functions.+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-}+module QuickSpec.Internal.Utils where++import Control.Arrow((&&&))+import Control.Exception+import Control.Spoon+import Data.List(groupBy, sortBy)+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif+import Data.Ord(comparing)+import System.IO+import qualified Control.Category as Category+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import Language.Haskell.TH.Syntax+import Data.Lens.Light+import Twee.Base hiding (lookup)+import Control.Monad.Trans.State.Strict+import Control.Monad++(#) :: Category.Category cat => cat b c -> cat a b -> cat a c+(#) = (Category..)++key :: Ord a => a -> Lens (Map a b) (Maybe b)+key x = lens (Map.lookup x) (\my m -> Map.alter (const my) x m)++keyDefault :: Ord a => a -> b -> Lens (Map a b) b+keyDefault x y = lens (Map.findWithDefault y x) (\y m -> Map.insert x y m)++reading :: (a -> Lens a b) -> Lens a b+reading f = lens (\x -> getL (f x) x) (\y x -> setL (f x) y x)++fstLens :: Lens (a, b) a+fstLens = lens fst (\x (_, y) -> (x, y))++sndLens :: Lens (a, b) b+sndLens = lens snd (\y (x, _) -> (x, y))++makeLensAs :: Name -> [(String, String)] -> Q [Dec]+makeLensAs ty names =+  nameMakeLens ty (\x -> lookup x names)++repeatM :: Monad m => m a -> m [a]+repeatM = sequence . repeat++partitionBy :: Ord b => (a -> b) -> [a] -> [[a]]+partitionBy value =+  map (map fst) .+  groupBy (\x y -> snd x == snd y) .+  sortBy (comparing snd) .+  map (id &&& value)++collate :: Ord a => ([b] -> c) -> [(a, b)] -> [(a, c)]+collate f = map g . partitionBy fst+  where+    g xs = (fst (head xs), f (map snd xs))++isSorted :: Ord a => [a] -> Bool+isSorted xs = and (zipWith (<=) xs (tail xs))++isSortedBy :: Ord b => (a -> b) -> [a] -> Bool+isSortedBy f xs = isSorted (map f xs)++usort :: Ord a => [a] -> [a]+usort = usortBy compare++usortBy :: (a -> a -> Ordering) -> [a] -> [a]+usortBy f = map head . groupBy (\x y -> f x y == EQ) . sortBy f++sortBy' :: Ord b => (a -> b) -> [a] -> [a]+sortBy' f = map snd . sortBy (comparing fst) . map (\x -> (f x, x))++usortBy' :: Ord b => (a -> b) -> [a] -> [a]+usortBy' f = map snd . usortBy (comparing fst) . map (\x -> (f x, x))++orElse :: Ordering -> Ordering -> Ordering+EQ `orElse` x = x+x  `orElse` _ = x++unbuffered :: IO a -> IO a+unbuffered x = do+  buf <- hGetBuffering stdout+  bracket_+    (hSetBuffering stdout NoBuffering)+    (hSetBuffering stdout buf)+    x++spoony :: Eq a => a -> Maybe a+spoony x = teaspoon ((x == x) `seq` x)++labelM :: Monad m => (a -> m b) -> [a] -> m [(a, b)]+labelM f = mapM (\x -> do { y <- f x; return (x, y) })++#if __GLASGOW_HASKELL__ < 710+isSubsequenceOf :: Ord a => [a] -> [a] -> Bool+[] `isSubsequenceOf` ys = True+(x:xs) `isSubsequenceOf` [] = False+(x:xs) `isSubsequenceOf` (y:ys)+  | x == y = xs `isSubsequenceOf` ys+  | otherwise = (x:xs) `isSubsequenceOf` ys+#endif++appendAt :: Int -> [a] -> [[a]] -> [[a]]+appendAt n xs [] = appendAt n xs [[]]+appendAt 0 xs (ys:yss) = (ys ++ xs):yss+appendAt n xs (ys:yss) = ys:appendAt (n-1) xs yss++-- Should be in Twee.Base.+antiunify :: Ord f => Term f -> Term f -> Term f+antiunify t u =+  build $ evalState (loop t u) (succ (snd (bound t) `max` snd (bound u)), Map.empty)+  where+    loop (App f ts) (App g us)+      | f == g =+        app f <$> zipWithM loop (unpack ts) (unpack us)+    loop (Var x) (Var y)+      | x == y =+        return (var x)+    loop t u = do+      (next, m) <- get+      case Map.lookup (t, u) m of+        Just v -> return (var v)+        Nothing -> do+          put (succ next, Map.insert (t, u) next m)+          return (var next)++{-# INLINE fixpoint #-}+fixpoint :: Eq a => (a -> a) -> a -> a+fixpoint f x = fxp x+  where+    fxp x+      | x == y = x+      | otherwise = fxp y+      where+        y = f x
− src/Test/QuickSpec.hs 
@@ -1,90 +0,0 @@--- | The main QuickSpec module.------ Look at the introduction (<https://github.com/nick8325/quickspec/blob/master/README.asciidoc>),--- read the examples (<http://github.com/nick8325/quickspec/tree/master/examples>),--- or read the paper (<http://www.cse.chalmers.se/~nicsma/quickspec.pdf>)--- before venturing in here.--module Test.QuickSpec-  (-- * Running QuickSpec-   quickSpec,-   sampleTerms,--   -- * The Signature class-   Sig,-   Signature(..),-   -- * Adding functions to a signature-   ---   -- | You can add @f@ to the signature by using @\"f\" \`funN\` f@,-   -- where @N@ is the arity of the function. For example,-   ---   -- > "&&" `fun2` (&&)-   ---   -- will add the binary function @(`&&`)@ to the signature.-   ---   -- If f is polymorphic, you must explicitly give it a monomorphic type.-   -- This module exports types `A`, `B` and `C` for that purpose.-   ---   -- For example:-   ---   -- > "++" `fun2` ((++) :: [A] -> [A] -> [A])-   ---   -- The result type of the function must be a member of `Ord`.-   -- If it isn't, use the `blindN` family of functions (below) instead.-   -- If you want to get equations over a type that isn't in `Ord`,-   -- you must use the `observerN` family of functions (below)-   -- to define an observation function for that type.-   con, fun0, fun1, fun2, fun3, fun4, fun5,-   -- * Adding functions whose results are not in `Ord`-   ---   -- | These functions work the same as `funN` (above),-   --   but don't use `Ord` to compare the results of the functions.-   --   Instead you can use the `observerN` family of functions (below)-   --   to define an observation function.-   blind0, blind1, blind2, blind3, blind4, blind5,-   -- * Adding variables to a signature-   vars,-   gvars,-   -- * Observational equality-   ---   -- | Use this to define comparison operators for types that have-   --   no `Ord` instance.-   ---   -- For example, suppose we have a type @Regex@ of regular expressions,-   -- and a matching function @match :: String -> Regex -> Bool@.-   -- We want our equations to talk about semantic equality of regular-   -- expressions, but we probably won't have an `Ord` instance that does that.-   -- Instead, we can use @blindN@ to add the regular expression operators-   -- to the signature, and then write-   ---   -- > observer2 match-   ---   -- (the @2@ is because @match@ has arity two).-   -- Then, when QuickSpec wants to compare two @Regex@es, @r1@ and @r2@, it will generate a random-   -- `String` @xs@, and compare @match xs r1@ with @match xs r2@.-   ---   -- Thus you can use `observerN` to get laws about things that can't-   -- be directly compared for equality but can be tested.-   observer1, observer2, observer3, observer4,-   -- * Modifying a signature-   background,-   withDepth,-   withSize,-   withTests,-   withQuickCheckSize,-   without,--   -- * The standard QuickSpec prelude, to include in your own signatures-   A, B, C,-   Two,-   prelude,-   bools,-   arith,-   lists,-   funs)--where--import Test.QuickSpec.Main-import Test.QuickSpec.Signature-import Test.QuickSpec.Prelude
− src/Test/QuickSpec/Approximate.hs 
@@ -1,67 +0,0 @@--- Utilities for testing functions that return partial results.-{-# LANGUAGE Rank2Types #-}-module Test.QuickSpec.Approximate where--import Test.QuickCheck-import Test.QuickCheck.Gen-import Test.QuickCheck.Random-import Test.QuickSpec.Signature-import Test.QuickSpec.Term-import Test.QuickSpec.Utils-import Test.QuickSpec.Utils.Typeable-import Control.Monad-import Control.Monad.Trans.Reader-import Control.Spoon-import System.Random-import Data.Monoid--newtype Plug = Plug { unPlug :: forall a. Partial a => Gen a -> Gen a }-type GP = ReaderT Plug Gen--plug :: Partial a => GP a -> GP a-plug x = ReaderT (\plug -> unPlug plug (runReaderT x plug))--class (Typeable a, Arbitrary a, Eq a) => Partial a where-  unlifted :: a -> GP a-  unlifted x = return x--lifted :: Partial a => a -> GP a-lifted x = plug (unlifted x)--instance Partial ()-instance Partial Int-instance Partial Integer-instance Partial Bool--instance Partial a => Partial [a] where-  unlifted [] = return []-  unlifted (x:xs) = liftM2 (:) (lifted x) (lifted xs)--approximate :: Partial a => (forall a. Partial a => a -> Maybe a) -> QCGen -> Int -> a -> a-approximate eval g n x = unGen (runReaderT (lifted x) (Plug plug)) g n-  where-    plug :: forall a. Partial a => Gen a -> Gen a-    plug x =-      sized $ \m ->-        if m == 0 then return (unGen arbitrary g 10)-        else resize (m-1) $ do-          y <- x-          case eval y of-            Just z -> return z-            Nothing -> return (unGen arbitrary g 10)--pobserver :: (Ord a, Partial a) => a -> Sig-pobserver x = observerSig (Observer (PGen (MkGen tot) (MkGen part)))-  where tot g n y = approximate Just g n (y `asTypeOf` x)-        part g n y = approximate spoony g n (y `asTypeOf` x)--genPartial :: Partial a => a -> Gen a-genPartial x = runReaderT (lifted x) (Plug plug)-  where-    plug x = frequency [(1, undefined), (3, x)]--pvars :: (Ord a, Partial a) => [String] -> a -> Sig-pvars xs w = pobserver w `mappend` primVars0 0 (zip xs (repeat (PGen g g')))-  where-    g = arbitrary `asTypeOf` return w-    g' = g >>= genPartial
− src/Test/QuickSpec/Equation.hs 
@@ -1,42 +0,0 @@--- | Equations.--module Test.QuickSpec.Equation where--import Test.QuickSpec.Term-import Test.QuickSpec.Signature hiding (vars)-import Test.QuickSpec.Utils.Typed-import Data.Monoid-import Data.List-import Data.Ord--data Equation = Term :=: Term deriving (Eq, Ord)--showEquation :: Sig -> Equation -> String-showEquation sig (t :=: u) =-  show (mapVars f t) ++ " == " ++ show (mapVars f u)-  where f = disambiguate sig (vars t ++ vars u)--instance Show Equation where-  show = showEquation mempty--data TypedEquation a = Expr a :==: Expr a--eraseEquation :: TypedEquation a -> Equation-eraseEquation (e1 :==: e2) = term e1 :=: term e2--instance Eq (TypedEquation a) where-  e1 == e2 = e1 `compare` e2 == EQ--instance Ord (TypedEquation a) where-  compare = comparing eraseEquation--instance Show (TypedEquation a) where-  show = show . eraseEquation--showTypedEquation :: Sig -> TypedEquation a -> String-showTypedEquation sig e = showEquation sig (eraseEquation e)--equations :: [Several Expr] -> [Some TypedEquation]-equations = sortBy (comparing (some eraseEquation)) .-            concatMap (several toEquations)-  where toEquations (x:xs) = [Some (y :==: x) | y <- xs]
− src/Test/QuickSpec/Generate.hs 
@@ -1,105 +0,0 @@--- | The testing loop and term generation of QuickSpec.--{-# LANGUAGE CPP, Rank2Types, TypeOperators, ScopedTypeVariables #-}-module Test.QuickSpec.Generate where--#include "errors.h"-import Test.QuickSpec.Signature hiding (con)-import qualified Test.QuickSpec.TestTree as T-import Test.QuickSpec.TestTree(TestResults, reps, classes, numTests, numResults, cutOff, discrete)-import Test.QuickSpec.Utils.Typed-import Test.QuickSpec.Utils.TypeRel(TypeRel)-import qualified Test.QuickSpec.Utils.TypeRel as TypeRel-import Test.QuickSpec.Utils.TypeMap(TypeMap)-import qualified Test.QuickSpec.Utils.TypeMap as TypeMap-import Test.QuickSpec.Term-import Text.Printf-import Test.QuickSpec.Utils.Typeable-import Test.QuickSpec.Utils-import Test.QuickCheck.Gen hiding (generate)-import Test.QuickCheck.Random-import System.Random-import Control.Spoon-import Test.QuickSpec.Utils.MemoValuation--terms :: Sig -> TypeRel Expr -> TypeRel Expr-terms = termsSatisfying (const True)--termsSatisfying :: (Term -> Bool) -> Sig -> TypeRel Expr -> TypeRel Expr-termsSatisfying p sig base =-  TypeMap.fromList-    [ Some (O (terms' p sig base w))-    | Some (Witness w) <- usort (saturatedTypes sig ++ variableTypes sig) ]--terms' :: Typeable a => (Term -> Bool) -> Sig -> TypeRel Expr -> a -> [Expr a]-terms' p sig base w =-  filter (\t -> size 1 (term t) <= maxSize sig && p (term t)) $-  map var (TypeRel.lookup w (variables sig)) ++-  map con (TypeRel.lookup w (constants sig)) ++-  [ app f x-  | Some (Witness w') <- lhsWitnesses sig w,-    x <- TypeRel.lookup w' base,-    not (isUndefined (term x)),-    f <- terms' p sig base (const w),-    arity f > 0,-    not (isUndefined (term f)) ]--test :: [(Valuation, QCGen, Int)] -> Sig ->-        TypeMap (List `O` Expr) -> TypeMap (TestResults `O` Expr)-test vals sig ts = fmap (mapSome2 (test' vals sig)) ts--test' :: forall a. Typeable a =>-         [(Valuation, QCGen, Int)] -> Sig -> [Expr a] -> TestResults (Expr a)-test' vals sig ts-  | not (testable sig (undefined :: a)) = discrete ts-  | otherwise =-    case observe undefined sig of-      Observer obs ->-        let testCase (val, g, n) x =-              spoony . unGen (partialGen obs) g n $ eval x val-        in cutOff base increment (T.test (map testCase vals) ts)-  where-    base = minTests sig `div` 2-    increment = minTests sig - base--genSeeds :: Int -> IO [(QCGen, Int)]-genSeeds maxSize = do-  rnd <- newQCGen-  let rnds rnd = rnd1 : rnds rnd2 where (rnd1, rnd2) = split rnd-  return (zip (rnds rnd) (concat (repeat [0,2..maxSize])))--toValuation :: Strategy -> Sig -> (QCGen, Int) -> (Valuation, QCGen, Int)-toValuation strat sig (g, n) =-  let (g1, g2) = split g-  in (memoValuation sig (unGen (valuation strat) g1 n), g2, n)--generate :: Bool -> Strategy -> Sig -> IO (TypeMap (TestResults `O` Expr))-generate shutUp strat sig = generateTermsSatisfying shutUp (const True) strat sig--generateTermsSatisfying :: Bool -> (Term -> Bool) -> Strategy -> Sig -> IO (TypeMap (TestResults `O` Expr))-generateTermsSatisfying shutUp p strat sig | maxDepth sig < 0 =-  ERROR "generate: maxDepth must be positive"-generateTermsSatisfying shutUp p strat sig | maxDepth sig == 0 = return TypeMap.empty-generateTermsSatisfying shutUp p strat sig = unbuffered $ do-  let d = maxDepth sig-      quietly x | shutUp = return ()-                | otherwise = x-  rs <- fmap (TypeMap.mapValues2 reps) (generate shutUp (const partialGen) (updateDepth (d-1) sig))-  quietly $ printf "Depth %d: " d-  let count :: ([a] -> a) -> (forall b. f (g b) -> a) ->-               TypeMap (f `O` g) -> a-      count op f = op . map (some2 f) . TypeMap.toList-      ts = termsSatisfying p sig rs-  quietly $ printf "%d terms, " (count sum length ts)-  seeds <- genSeeds (maxQuickCheckSize sig)-  let cs = test (map (toValuation strat sig) seeds) sig ts-  quietly $-    printf "%d tests, %d evaluations, %d classes, %d raw equations.\n"-      (count (maximum . (0:)) numTests cs)-      (count sum numResults cs)-      (count sum (length . classes) cs)-      (count sum (sum . map (subtract 1 . length) . classes) cs)-  return cs--eraseClasses :: TypeMap (TestResults `O` Expr) -> [[Tagged Term]]-eraseClasses = concatMap (some (map (map (tagged term)) . classes . unO)) . TypeMap.toList
− src/Test/QuickSpec/Main.hs 
@@ -1,166 +0,0 @@--- | The main implementation of QuickSpec.--{-# LANGUAGE CPP, TypeOperators #-}-module Test.QuickSpec.Main where--#include "errors.h"--import Test.QuickSpec.Generate-import Test.QuickSpec.Reasoning.NaiveEquationalReasoning hiding (universe, maxDepth)-import Test.QuickSpec.Utils.Typed-import qualified Test.QuickSpec.Utils.TypeMap as TypeMap-import qualified Test.QuickSpec.Utils.TypeRel as TypeRel-import Test.QuickSpec.Signature hiding (vars)-import Test.QuickSpec.Term hiding (symbols)-import Control.Monad-import Text.Printf-import Data.Monoid-import Test.QuickSpec.TestTree(TestResults, classes, reps)-import Data.List-import System.Random-import Data.Monoid-import Data.Maybe-import Test.QuickSpec.Utils-import Test.QuickSpec.Equation--undefinedsSig :: Sig -> Sig-undefinedsSig sig =-  background-    [ undefinedSig "undefined" (undefined `asTypeOf` witness x)-    | Some x <- saturatedTypes sig ]--universe :: [[Tagged Term]] -> [Tagged Term]-universe css = filter (not . isUndefined . erase) (concat css)--prune :: Context -> [Term] -> (a -> Equation) -> [a] -> [a]-prune ctx reps erase eqs = evalEQ ctx (filterM (fmap not . provable . erase) eqs)-  where-    provable (t :=: u) = do-      res <- t =?= u-      if res then return True else do-        state <- get-        -- Check that we won't unify two representatives---if we do-        -- the equation is false-        t =:= u-        reps' <- mapM rep reps-        if sort reps' == usort reps' then return False else do-          put state-          return True--defines :: Equation -> Maybe Symbol-defines (t :=: u) = do-  let isVar Var{} = True-      isVar _ = False--      acyclic t =-        all acyclic (args t) &&-        case functor t == functor u of-          True -> usort (map Var (vars t)) `isProperSubsetOf` args u-          False -> True-      xs `isProperSubsetOf` ys = xs `isSubsetOf` ys && sort xs /= sort ys-      xs `isSubsetOf` ys = sort xs `isSublistOf` sort ys-      [] `isSublistOf` _ = True-      (x:xs) `isSublistOf` [] = False-      (x:xs) `isSublistOf` (y:ys)-        | x == y = xs `isSublistOf` ys-        | otherwise = (x:xs) `isSublistOf` ys--  guard (all isVar (args u) && usort (args u) == args u &&-         acyclic t && vars t `isSubsetOf` vars u)--  return (functor u)--definitions :: [Equation] -> [Equation]-definitions es = [ e | e <- es, defines e /= Nothing ]--runTool :: Signature a => (Sig -> IO ()) -> a -> IO ()-runTool tool sig_ = do-  putStrLn "== API =="-  putStr (show (signature sig_))-  let sig = signature sig_ `mappend` undefinedsSig (signature sig_)--  tool sig--data Target = Target Symbol | NoTarget deriving (Eq, Ord)--target :: Equation -> Target-target (t :=: u) =-  case usort (filter p (funs t ++ funs u)) of-    [f] -> Target f-    _ -> NoTarget-  where p x = not (silent x) && symbolArity x > 0--innerZip :: [a] -> [[b]] -> [[(a,b)]]-innerZip [] _ = []-innerZip _ [] = []-innerZip xs ([]:yss) = []:innerZip xs yss-innerZip (x:xs) ((y:ys):yss) =-  let (zs:zss) = innerZip xs (ys:yss)-  in ((x,y):zs):zss---- | Run QuickSpec on a signature.-quickSpec :: Signature a => a -> IO ()-quickSpec = runTool $ \sig -> do-  putStrLn "== Testing =="-  r <- generate False (const partialGen) sig-  let clss = concatMap (some2 (map (Some . O) . classes)) (TypeMap.toList r)-      univ = concatMap (some2 (map (tagged term))) clss-      reps = map (some2 (tagged term . head)) clss-      eqs = equations clss-  printf "%d raw equations; %d terms in universe.\n\n"-    (length eqs)-    (length reps)--  let ctx = initial (maxDepth sig) (symbols sig) univ-      allEqs = map (some eraseEquation) eqs-      isBackground = all silent . eqnFuns-      keep eq = not (isBackground eq) || absurd eq-      absurd (t :=: u) = absurd1 t u || absurd1 u t-      absurd1 (Var x) t = x `notElem` vars t-      absurd1 _ _ = False-      (background, foreground) =-        partition isBackground allEqs-      pruned = filter keep-                 (prune ctx (filter (not . isUndefined) (map erase reps)) id-                   (background ++ foreground))-      eqnFuns (t :=: u) = funs t ++ funs u-      isGround (t :=: u) = null (vars t) && null (vars u)-      byTarget = innerZip [1 :: Int ..] (partitionBy target pruned)--  forM_ byTarget $ \eqs@((_,eq):_) -> do-    case target eq of-      NoTarget -> putStrLn "== Equations about several functions =="-      Target f -> printf "== Equations about %s ==\n" (show f)-    forM_ eqs $ \(i, eq) ->-      printf "%3d: %s\n" i (showEquation sig eq)-    putStrLn ""--sampleList :: StdGen -> Int -> [a] -> [a]-sampleList g n xs | n >= length xs = xs-                  | otherwise = aux g n (length xs) xs-  where-    aux g 0 _ _ = []-    aux g _ _ [] = ERROR "sampleList: bug in sampling"-    aux g size len (x:xs)-      | i <= size = x:aux g' (size-1) (len-1) xs-      | otherwise = aux g' size (len-1) xs-      where (i, g') = randomR (1, len) g---- | Generate random terms from a signature. Useful when QuickSpec is---   generating too many terms and you want to know what they look like.-sampleTerms :: Signature a => a -> IO ()-sampleTerms = runTool $ \sig -> do-  putStrLn "== Testing =="-  r <- generate False (const partialGen) (updateDepth (maxDepth sig - 1) sig)-  let univ = sort . concatMap (some2 (map term)) . TypeMap.toList . terms sig .-             TypeMap.mapValues2 reps $ r-  printf "Universe contains %d terms.\n\n" (length univ)--  let numTerms = 100--  printf "== Here are %d terms out of a total of %d ==\n" numTerms (length univ)-  g <- newStdGen-  forM_ (zip [1 :: Int ..] (sampleList g numTerms univ)) $ \(i, t) ->-    printf "%d: %s\n" i (show (mapVars (disambiguate sig (vars t)) t))--  putStrLn ""
− src/Test/QuickSpec/Prelude.hs 
@@ -1,96 +0,0 @@--- | The \"prelude\": a standard signature containing useful functions---   like '++', which can be used as background theory.--{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}-module Test.QuickSpec.Prelude where--import Test.QuickSpec.Signature-import Test.QuickSpec.Approximate-import Test.QuickCheck-import Data.Typeable---- | Just a type.---   You can instantiate your polymorphic functions at this type---   to include them in a signature.-newtype A = A Int deriving (Eq, Ord, Typeable, Arbitrary, CoArbitrary, Show)-newtype B = B Int deriving (Eq, Ord, Typeable, Arbitrary, CoArbitrary, Show)-newtype C = C Int deriving (Eq, Ord, Typeable, Arbitrary, CoArbitrary, Show)--instance Partial A where unlifted (A x) = fmap A (unlifted x)-instance Partial B where unlifted (B x) = fmap B (unlifted x)-instance Partial C where unlifted (C x) = fmap C (unlifted x)---- | A type with two elements.---   Use this instead of @A@ if testing doesn't work well because---   the domain of @A@ is too large.-data Two = One | Two deriving (Eq, Ord, Typeable, Show)--instance Arbitrary Two where-  arbitrary = elements [One, Two]--instance CoArbitrary Two where-  coarbitrary One = variant 0-  coarbitrary Two = variant (-1)---- | A signature containing boolean functions:--- @(`||`)@, @(`&&`)@, `not`, `True`, `False`.-bools :: Sig-bools = background [-  ["x", "y", "z"] `vars` (undefined :: Bool),--  "||"    `fun2` (||),-  "&&"    `fun2` (&&),-  "not"   `fun1` not,-  "True"  `fun0` True,-  "False" `fun0` False]---- | A signature containing arithmetic operations:--- @0@, @1@, @(`+`)@, @(`*`)@.--- Instantiate it with e.g. @arith (undefined :: `Int`)@.-arith :: forall a. (Typeable a, Ord a, Num a, Arbitrary a) => a -> Sig-arith _ = background [-  ["x", "y", "z"] `vars` (undefined :: a),--  "0" `fun0` (0   :: a),-  "1" `fun0` (1   :: a),-  "+" `fun2` ((+) :: a -> a -> a),-  "*" `fun2` ((*) :: a -> a -> a)]---- | A signature containing list operations:--- @[]@, @(:)@, `head`, `tail`, @(`++`)@.--- Instantiate it with e.g. @lists (undefined :: `A`)@.-lists :: forall a. (Typeable a, Ord a, Arbitrary a) => a -> Sig-lists _ = background [-  ["xs", "ys", "zs"] `vars` (undefined :: [a]),--  "[]"      `fun0` ([]      :: [a]),-  ":"       `fun2` ((:)     :: a -> [a] -> [a]),-  "head"    `fun1` (head    :: [a] -> a),-  "tail"    `fun1` (tail    :: [a] -> [a]),-  "++"      `fun2` ((++)    :: [a] -> [a] -> [a])]---- | A signature containing higher-order functions:--- @(`.`)@, `id`, and some function variables.--- Useful for testing `map`.-funs :: forall a. (Typeable a, Ord a, Arbitrary a, CoArbitrary a) => a -> Sig-funs _ = background [-  ["f", "g", "h"] `vars` (undefined :: a -> a),--  "."  `blind2` ((.) :: (a -> a) -> (a -> a) -> (a -> a)),-  "id" `blind0` (id  :: a -> a),--  observer2 (\(x :: a) (f :: a -> a) -> f x)-  ]---- | The QuickSpec prelude.--- Contains boolean, arithmetic and list functions,--- and some variables.--- Instantiate it as e.g. @prelude (undefined :: `A`)@.--- For more precise control over what gets included,--- see 'bools', 'arith', 'lists', 'funs' and 'without'.-prelude :: (Typeable a, Ord a, Arbitrary a) => a -> Sig-prelude a = background [-  ["x", "y", "z"] `vars` a,-  bools,-  arith (undefined :: Int),-  lists a ]
− src/Test/QuickSpec/Reasoning/CongruenceClosure.hs 
@@ -1,167 +0,0 @@--- | A decision procedure for ground equality,---   based on the paper "Proof-producing Congruence Closure".--module Test.QuickSpec.Reasoning.CongruenceClosure(CC, newSym, (=:=), (=?=), rep, evalCC, execCC, runCC, ($$), S, funUse, argUse, lookup, initial, frozen) where--import Prelude hiding (lookup)-import Control.Monad-import Control.Monad.Trans.State.Strict-import Data.IntMap(IntMap)-import qualified Data.IntMap as IntMap-import Test.QuickSpec.Reasoning.UnionFind(UF, Replacement((:>)))-import qualified Test.QuickSpec.Reasoning.UnionFind as UF-import Data.Maybe-import Data.List(foldl')--- import Test.QuickCheck--- import Test.QuickCheck.Arbitrary--- import Test.QuickCheck.Monadic-import Text.Printf--lookup2 :: Int -> Int -> IntMap (IntMap a) -> Maybe a-lookup2 k1 k2 m = IntMap.lookup k2 (IntMap.findWithDefault IntMap.empty k1 m)--insert2 :: Int -> Int -> a -> IntMap (IntMap a) -> IntMap (IntMap a)-insert2 k1 k2 v m = IntMap.insertWith IntMap.union k1 (IntMap.singleton k2 v) m--delete2 :: Int -> Int -> IntMap (IntMap a) -> IntMap (IntMap a)-delete2 k1 k2 m = IntMap.adjust (IntMap.delete k2) k1 m--data FlatEqn = (Int, Int) := Int deriving (Eq, Ord)--data S = S {-      -- in all these maps, the keys are representatives, the values may not be-      funUse :: !(IntMap [(Int, Int)]),-      argUse :: !(IntMap [(Int, Int)]),-      lookup :: IntMap (IntMap Int),-      uf :: UF.S-    }--type CC = State S--liftUF :: UF a -> CC a-liftUF m = do-  s <- get-  let (x, uf') = UF.runUF (uf s) m-  put s { uf = uf' }-  return x--invariant :: String -> CC ()-invariant _ = return ()--- invariant str = do---   S funUse argUse lookup <- get---   -- keys of all maps are representatives---   let check phase x = do---        b <- liftUF (UF.isRep x)---        if b then return () else error (printf "%s, %s appears as a key in %s but is not a rep in:\nfunUse=%s\nargUse=%s\nlookup=%s" str (show x) phase (show funUse) (show argUse) (show lookup))---   mapM_ (check "funUse") (IntMap.keys funUse)---   mapM_ (check "argUse") (IntMap.keys argUse)---   mapM_ (check "lookup") (IntMap.keys lookup)---   mapM_ (mapM_ (check "inner lookup") . IntMap.keys) (IntMap.elems lookup)--modifyFunUse f = modify (\s -> s { funUse = f (funUse s) })-modifyArgUse f = modify (\s -> s { argUse = f (argUse s) })-addFunUses xs s = modifyFunUse (IntMap.insertWith (++) s xs)-addArgUses xs s = modifyArgUse (IntMap.insertWith (++) s xs)-modifyLookup f = modify (\s -> s { lookup = f (lookup s) })-putLookup l = modifyLookup (const l)--newSym :: CC Int-newSym = liftUF UF.newSym--($$) :: Int -> Int -> CC Int-f $$ x = do-  invariant (printf "before %s$$%s" (show f) (show x))-  m <- gets lookup-  f' <- rep f-  x' <- rep x-  invariant (printf "at %s$$%s:1" (show f) (show x))-  case lookup2 x' f' m of-    Nothing -> do-      c <- newSym-      invariant (printf "at %s$$%s:2" (show f) (show x))-      putLookup (insert2 x' f' c m)-      addFunUses [(x', c)] f'-      addArgUses [(f', c)] x'-      invariant (printf "after %s$$%s" (show f) (show x))-      return c-    Just k -> return k--(=:=) :: Int -> Int -> CC Bool-a =:= b = propagate (a, b)--(=?=) :: Int -> Int -> CC Bool-t =?= u = liftM2 (==) (rep t) (rep u)--propagate (a, b) = do-  (unified, pending) <- propagate1 (a, b)-  mapM_ propagate pending-  return unified--propagate1 (a, b) = do-  invariant (printf "before propagate (%s, %s)" (show a) (show b))-  res <- liftUF (a UF.=:= b)-  case res of-    Nothing -> return (False, [])-    Just (r :> r') -> do-      funUses <- gets (IntMap.lookup r . funUse)-      argUses <- gets (IntMap.lookup r . argUse)-      case (funUses, argUses) of-        (Nothing, Nothing) -> return (True, [])-        _ -> fmap (\x -> (True, x)) (updateUses r r' (fromMaybe [] funUses) (fromMaybe [] argUses))--updateUses r r' funUses argUses = do-  modifyFunUse (IntMap.delete r)-  modifyArgUse (IntMap.delete r)-  modifyLookup (IntMap.delete r)-  forM_ funUses $ \(x, _) -> do-    x' <- rep x-    modifyLookup (delete2 x' r)-  invariant (printf "after deleting %s" (show r))-  let repPair (x, c) = do-        x' <- rep x-        return (x', c)-  funUses' <- mapM repPair funUses-  argUses' <- mapM repPair argUses--  m <- gets lookup--  let foldUses insert lookup pending m uses = foldl' op e uses-        where op (pending, newUses, m) (x', c) =-                case lookup x' m of-                  Just k -> ((c, k):pending, newUses, m)-                  Nothing -> (pending, (x', c):newUses, insert x' c m)-              e = (pending, [], m)--      (funPending, funNewUses, m') = foldUses (\x' c m -> insert2 x' r' c m)-                                              (\x' m -> lookup2 x' r' m)-                                              [] m funUses'--      (pending, argNewUses, argM) = foldUses IntMap.insert IntMap.lookup funPending-                                             (IntMap.findWithDefault IntMap.empty r' m')-                                             argUses'--  addFunUses funNewUses r'-  addArgUses argNewUses r'--  putLookup (if IntMap.null argM then m' else IntMap.insert r' argM m')-  invariant (printf "after updateUses (%s, %s)" (show r) (show r'))--  return pending--rep :: Int -> CC Int-rep s = liftUF (UF.rep s)--runCC :: S -> CC a -> (a, S)-runCC s m = runState m s--evalCC :: S -> CC a -> a-evalCC s m = fst (runCC s m)--execCC :: S -> CC a -> S-execCC s m = snd (runCC s m)--initial :: Int -> S-initial n = S IntMap.empty IntMap.empty IntMap.empty (UF.initial n)--frozen :: CC a -> CC a-frozen x = fmap (evalState x) get
− src/Test/QuickSpec/Reasoning/NaiveEquationalReasoning.hs 
@@ -1,128 +0,0 @@--- | Equational reasoning built on top of congruence closure.--{-# LANGUAGE CPP, TupleSections #-}-module Test.QuickSpec.Reasoning.NaiveEquationalReasoning where--#include "errors.h"--import Test.QuickSpec.Term-import Test.QuickSpec.Equation-import Test.QuickSpec.Reasoning.CongruenceClosure(CC)-import qualified Test.QuickSpec.Reasoning.CongruenceClosure as CC-import Data.Map(Map)-import qualified Data.Map as Map-import Data.IntMap(IntMap)-import qualified Data.IntMap as IntMap-import Control.Monad-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Strict-import qualified Control.Monad.Trans.State.Strict as S-import Test.QuickSpec.Utils-import Test.QuickSpec.Utils.Typed-import Test.QuickSpec.Utils.Typeable-import Data.Ord-import Data.List--data Context = Context {-  rel :: CC.S,-  maxDepth :: Int,-  universe :: IntMap Universe-  }--type Universe = IntMap [Int]--type EQ = ReaderT (Int, IntMap Universe) CC--initial :: Int -> [Symbol] -> [Tagged Term] -> Context-initial d syms ts =-  let n = 1+maximum (0:map index syms)-      (universe, rel) =-        CC.runCC (CC.initial n) $-          forM (partitionBy (witnessType . tag) ts) $ \xs@(x:_) ->-            fmap (witnessType (tag x),) (createUniverse (map erase xs))-      univMap = Map.fromList universe--  in Context rel d . IntMap.fromList $ [-    (index sym,-     Map.findWithDefault IntMap.empty (symbolType sym) univMap)-    | sym <- syms ]--createUniverse :: [Term] -> CC Universe-createUniverse ts = fmap IntMap.fromList (mapM createTerms tss)-  where tss = partitionBy depth ts-        createTerms ts@(t:_) = fmap (depth t,) (mapM flatten ts)--runEQ :: Context -> EQ a -> (a, Context)-runEQ ctx x = (y, ctx { rel = rel' })-  where (y, rel') = runState (runReaderT x (maxDepth ctx, universe ctx)) (rel ctx)--evalEQ :: Context -> EQ a -> a-evalEQ ctx x = fst (runEQ ctx x)--execEQ :: Context -> EQ a -> Context-execEQ ctx x = snd (runEQ ctx x)--liftCC :: CC a -> EQ a-liftCC x = ReaderT (const x)--(=?=) :: Term -> Term -> EQ Bool-t =?= u = liftCC $ do-  x <- flatten t-  y <- flatten u-  x CC.=?= y--equal :: Equation -> EQ Bool-equal (t :=: u) = t =?= u--(=:=) :: Term -> Term -> EQ Bool-t =:= u = unify (t :=: u)--unify :: Equation -> EQ Bool-unify (t :=: u) = do-  (d, ctx) <- ask-  b <- t =?= u-  unless b $-    forM_ (substs t ctx d ++ substs u ctx d) $ \s -> liftCC $ do-      t' <- subst s t-      u' <- subst s u-      t' CC.=:= u'-  return b--type Subst = Symbol -> Int--substs :: Term -> IntMap Universe -> Int -> [Subst]-substs t univ d = map lookup (sequence (map choose vars))-  where vars = map (maximumBy (comparing snd)) .-               partitionBy fst .-               holes $ t--        choose (x, n) =-          let m = IntMap.findWithDefault (ERROR "empty universe")-                  (index x) univ in-          [ (x, t)-          | d' <- [0..d-n],-            t <- IntMap.findWithDefault [] d' m ]--        lookup ss =-          let m = IntMap.fromList [ (index x, y) | (x, y) <- ss ]-          in \x -> IntMap.findWithDefault (index x) (index x) m--subst :: Subst -> Term -> CC Int-subst s (Var x) = return (s x)-subst s (Const x) = return (index x)-subst s (App f x) = do-  f' <- subst s f-  x' <- subst s x-  f' CC.$$ x'--flatten :: Term -> CC Int-flatten = subst index--get :: EQ CC.S-get = liftCC S.get--put :: CC.S -> EQ ()-put x = liftCC (S.put x)--rep :: Term -> EQ Int-rep x = liftCC (flatten x >>= CC.rep)
− src/Test/QuickSpec/Reasoning/PartialEquationalReasoning.hs 
@@ -1,141 +0,0 @@--- | Equational reasoning that deals with partial functions.---   Only used in HipSpec at the moment.--{-# LANGUAGE CPP #-}-module Test.QuickSpec.Reasoning.PartialEquationalReasoning where--#include "errors.h"-import Test.QuickSpec.Equation-import Test.QuickSpec.Term hiding (Variable, vars)-import qualified Test.QuickSpec.Term as Term-import Test.QuickSpec.Utils.Typed-import qualified Test.QuickSpec.Reasoning.NaiveEquationalReasoning as EQ-import Test.QuickSpec.Reasoning.NaiveEquationalReasoning(EQ, evalEQ, runEQ)-import Data.IntMap(IntMap)-import qualified Data.IntMap as IntMap-import Control.Monad.Trans.State-import qualified Control.Monad.Trans.State as S-import Data.List-import Data.Ord-import Test.QuickSpec.Utils-import Test.QuickSpec.Signature hiding (vars)-import Data.Monoid-import Control.Monad--data PEquation = Precondition :\/: Equation-type Precondition = [Symbol]-data Totality = Partial | Total [Int] | Variable deriving (Eq, Ord, Show)--instance Eq PEquation where-  e1 == e2 = e1 `compare` e2 == EQ--instance Ord PEquation where-  compare = comparing stamp-    where stamp (pre :\/: eq) = (eq, length pre, usort pre)--instance Show PEquation where-  show = showPEquation mempty--showPEquation :: Sig -> PEquation -> String-showPEquation sig (pre :\/: t :=: u) =-  show (mapVars f t) ++ " == " ++ show (mapVars f u) ++-  showPre (map f pre)-  where f = disambiguate sig (Term.vars t ++ Term.vars u ++ pre)-        showPre [] = ""-        showPre xs = " when " ++ conjunction (map show xs) ++ " " ++ plural xs "is" "are" ++ " partial"-        plural xs x y-          | length xs == 1 = x-          | otherwise = y-        conjunction [x] = x-        conjunction xs =-          intercalate ", " (init xs) ++ " and " ++ last xs--infix 5 :\/:--data Context = Context {-  total :: EQ.Context,-  partial :: IntMap EQ.Context,-  vars :: IntMap Symbol-  }--type PEQ = State Context--initial :: Int -> [(Symbol, Totality)] -> [Tagged Term] -> Context-initial d syms univ-  | ok syms = Context total partial vars-  | otherwise = __-  where-    ok syms = and (zipWith (==) [0..] (map (index . fst) syms))-    total = EQ.initial d (map fst syms) (filter (isTotal Nothing [] . erase) univ)-    partial = IntMap.fromList [-      (i, EQ.initial d (map fst syms) (filter (isTotal (Just i) [] . erase) univ))-      | (i, (sym, Variable)) <- zip [0..] syms-      ]-    totality = IntMap.fromList [(index sym, tot) | (sym, tot) <- syms]-    isTotal ctx args (Var x) = ctx /= Just (index x) && all (isTotal ctx []) args-    isTotal ctx args (App f x) = isTotal ctx (x:args) f-    isTotal ctx args (Const x) =-      case IntMap.findWithDefault-           (ERROR "type not found")-           (index x) totality of-        Partial -> False-        Total pre -> and [ isTotal ctx [] arg || i `elem` pre | (i, arg) <- zip [0..] args ]-        Variable -> __-    vars = IntMap.fromList [(index s, s) | (s, Variable) <- syms]--runPEQ :: Context -> PEQ a -> (a, Context)-runPEQ = flip runState--evalPEQ :: Context -> PEQ a -> a-evalPEQ ctx x = fst (runPEQ ctx x)--execPEQ :: Context -> PEQ a -> Context-execPEQ ctx x = snd (runPEQ ctx x)--liftEQ :: [Int] -> (Maybe Int -> EQ a) -> PEQ [a]-liftEQ pre x = do-  Context total partial vars <- S.get-  let (totalRes, total') = runEQ total (x Nothing)-      (partialRes, partial') = IntMap.mapAccumWithKey f [] partial-      f rs i ctx-        | i `elem` pre = runEQ ctx (fmap (:rs) (x (Just i)))-        | otherwise = (rs, ctx)-  S.put (Context total' partial' vars)-  return (totalRes:partialRes)--equal :: PEquation -> PEQ Bool-equal (pre :\/: t :=: u) = liftM2 (==) (rep pre t) (rep pre u)--irrelevant :: Equation -> PEQ Precondition-irrelevant (t :=: u) = do-  vs <- gets (IntMap.elems . vars)-  return (vs \\ (Term.vars t `intersect` Term.vars u))--unify :: PEquation -> PEQ Bool-unify (pre :\/: eq) = do-  irr <- irrelevant eq-  fmap and . liftEQ (map index (pre ++ irr)) $ \n ->-    case n of-      Just i | i `notElem` map index pre -> return True-      _ -> EQ.unify eq--precondition :: Equation -> PEQ Precondition-precondition eq = do-  Context _ partial vars <- S.get-  fmap concat . liftEQ (IntMap.keys partial) $ \n ->-    case n of-      Nothing -> return []-      Just i -> do-        r <- EQ.equal eq-        if r then-           return [IntMap.findWithDefault (ERROR "precondition: var not found") i vars]-          else return []--get :: PEQ Context-get = S.get--put :: Context -> PEQ ()-put = S.put--rep :: Precondition -> Term -> PEQ [Int]-rep pre t = liftEQ (map index pre) (const (EQ.rep t))
− src/Test/QuickSpec/Reasoning/UnionFind.hs 
@@ -1,64 +0,0 @@--- | A union-find data structure.--module Test.QuickSpec.Reasoning.UnionFind(UF, Replacement((:>)), newSym, (=:=), rep, evalUF, execUF, runUF, S, isRep, initial) where--import Prelude hiding (min)-import Control.Monad-import Control.Monad.Trans.State.Strict-import Data.IntMap(IntMap)-import qualified Data.IntMap as IntMap--data S = S {-      links :: IntMap Int,-      sym :: Int-    }--type UF = State S-data Replacement = Int :> Int--runUF :: S -> UF a -> (a, S)-runUF s m = runState m s--evalUF :: S -> UF a -> a-evalUF s m = fst (runUF s m)--execUF :: S -> UF a -> S-execUF s m = snd (runUF s m)--initial :: Int -> S-initial n = S IntMap.empty n--modifyLinks f = modify (\s -> s { links = f (links s) })-modifySym f = modify (\s -> s { sym = f (sym s) })-putLinks l = modifyLinks (const l)--newSym :: UF Int-newSym = do-  s <- get-  modifySym (+1)-  return (sym s)--(=:=) :: Int -> Int -> UF (Maybe Replacement)-s =:= t | s == t = return Nothing-s =:= t = do-  rs <- rep s-  rt <- rep t-  if (rs /= rt) then do-    modifyLinks (IntMap.insert rs rt)-    return (Just (rs :> rt))-   else return Nothing--rep :: Int -> UF Int-rep t = do-  m <- fmap links get-  case IntMap.lookup t m of-    Nothing -> return t-    Just t' -> do-      r <- rep t'-      when (t' /= r) $ modifyLinks (IntMap.insert t r)-      return r--isRep :: Int -> UF Bool-isRep t = do-  t' <- rep t-  return (t == t')
− src/Test/QuickSpec/Signature.hs 
@@ -1,590 +0,0 @@--- | Functions for constructing and analysing signatures.--{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification, ScopedTypeVariables, DeriveDataTypeable #-}-module Test.QuickSpec.Signature where--#include "errors.h"-import Control.Applicative hiding (some)-import Test.QuickSpec.Utils.Typeable-import Data.Monoid-import Test.QuickCheck-import Test.QuickSpec.Term hiding (var, vars)-import Test.QuickSpec.Utils.Typed-import qualified Test.QuickSpec.Utils.TypeMap as TypeMap-import Test.QuickSpec.Utils.TypeMap(TypeMap)-import qualified Test.QuickSpec.Utils.TypeRel as TypeRel-import Test.QuickSpec.Utils.TypeRel(TypeRel)-import Data.List-import qualified Data.Map as Map-import Test.QuickSpec.Utils-import Data.Maybe-import Control.Monad---- | The class of things that can be used as a signature.-class Signature a where-  signature :: a -> Sig--instance Signature Sig where-  signature = id--instance Signature a => Signature [a] where-  signature = mconcat . map signature---- | A signature.-data Sig = Sig {-  -- Constants, variables, generators and observation functions.-  constants :: TypeRel Constant,-  variables :: TypeRel Variable,-  total     :: TypeMap Gen,-  partial   :: TypeMap Gen,-  observers :: TypeMap Observer,--  -- Ord instances, added whenever the 'fun' family of functions is used.-  ords :: TypeMap Observer,--  -- Witnesses for Typeable. The following types must have witnesses:-  --  * Any function argument.-  --  * Any function result.-  --  * Any partially-applied function type.-  --  * Any variable type.-  witnesses :: TypeMap Witnessed,--  -- Depth of terms in the universe.-  maxDepth_ :: First Int,--  -- Size of terms in the universe.-  maxSize_ :: First Int,--  -- Minimum number of tests to run.-  minTests_ :: First Int,--  -- Maximum size parameter to pass to QuickCheck.-  maxQuickCheckSize_ :: First Int-  } deriving Typeable--maxDepth :: Sig -> Int-maxDepth = fromMaybe 3 . getFirst . maxDepth_--maxSize :: Sig -> Int-maxSize = fromMaybe 100 . getFirst . maxSize_--updateDepth :: Int -> Sig -> Sig-updateDepth n sig = sig { maxDepth_ = First (Just n) }--updateSize :: Int -> Sig -> Sig-updateSize n sig = sig { maxSize_ = First (Just n) }--minTests :: Sig -> Int-minTests = fromMaybe 500 . getFirst . minTests_--maxQuickCheckSize :: Sig -> Int-maxQuickCheckSize = fromMaybe 20 . getFirst . maxQuickCheckSize_--instance Show Sig where show = show . summarise--data Used = Used Witness [Symbol]-instance Show Used where-  show (Used w ks) =-    show w ++ " (used in " ++ intercalate ", " (map show ks) ++ ")"--uses :: Sig -> Witness -> Used-uses sig w =-  Used w-    [ sym (unConstant k)-    | Some k <- TypeRel.toList (constants sig),-      w' <- constantArgs sig k,-      w == w' ]--data Summary = Summary {-  summaryFunctions :: [Symbol],-  summaryBackground :: [Symbol],-  summaryVariables :: [Symbol],-  summaryObserved :: [TypeRep],-  summaryUninhabited :: [Used],-  summaryNoVars :: [TypeRep],-  summaryUntestable :: [TypeRep],-  summaryDepth :: Maybe Int,-  summarySize :: Maybe Int,-  summaryTests :: Maybe Int,-  summaryQuickCheckSize :: Maybe Int-  }--instance Show Summary where-  show summary = unlines $-    section ["-- functions --"] (decls (summaryFunctions summary)) ++-    section ["-- background functions --"] (decls (summaryBackground summary)) ++-    section ["-- variables --"] (decls (summaryVariables summary)) ++-    section ["-- the following types are using non-standard equality --"]-      (map show (summaryObserved summary)) ++-    section ["-- WARNING: the following types are uninhabited --"]-      (map show (summaryUninhabited summary)) ++-    section ["-- WARNING: there are no variables of the following types; consider adding some --"]-      (map show (summaryNoVars summary)) ++-    section ["-- WARNING: cannot test the following types; ",-             "            consider using 'fun' instead of 'blind' or using 'observe' --"]-      (map show (summaryUntestable summary))-    where-      section _ [] = []-      section msg xs = msg ++ xs ++ [""]--      decls xs = map decl (partitionBy symbolType xs)--      decl xs@(x:_) =-        intercalate ", " (map show xs) ++ " :: " ++ show (symbolType x)--sigToHaskell :: Signature a => a -> String-sigToHaskell sig = "signature [\n" ++ intercalate ",\n" (map ("  " ++) ls) ++ "]"-  where-    summary = summarise (signature sig)-    ls =-      [ function s | s <- summaryFunctions summary ] ++-      [ background s | s <- summaryBackground summary ] ++-      [ variable ss | ss <- partitionBy symbolType (summaryVariables summary) ] ++-      [ "withDepth " ++ show n | Just n <- [summaryDepth summary] ] ++-      [ "withSize " ++ show n | Just n <- [summarySize summary] ] ++-      [ "withTests " ++ show n | Just n <- [summaryTests summary] ] ++-      [ "withQuickCheckSize " ++ show n | Just n <- [summaryQuickCheckSize summary] ]-    function s = "\"" ++ show s ++ "\" `fun" ++ show (symbolArity s) ++ "` (" ++-                 show s ++ " :: " ++ show (symbolType s) ++ ")"-    background s = "background $ " ++ function s-    variable ss@(s:_) =-      show (map name ss) ++ " `vars" ++ show (symbolArity s) ++-      "` (undefined :: " ++ show (symbolType s) ++ ")"--summarise :: Sig -> Summary-summarise sig =-  Summary {-    summaryFunctions = filter (not . silent) allConstants,-    summaryBackground = filter silent allConstants,-    summaryVariables = allVariables,-    summaryObserved = Map.keys (observers sig),-    summaryUninhabited =-      [ uses sig ty-      | ty <- argumentTypes sig,-        ty `notElem` inhabitedTypes sig,-        ty `notElem` variableTypes sig ],-    summaryNoVars =-      [ witnessType ty-      | ty <- argumentTypes sig,-        -- There is a non-variable term of this type and it appears as the-        -- argument to some function-        ty `elem` inhabitedTypes sig,-        ty `notElem` variableTypes sig ],-    summaryUntestable =-      [ witnessType ty-      | ty@(Some (Witness w)) <- saturatedTypes sig,-        -- The type is untestable and is the result type of a constant-        not (testable sig w) ],-    summaryDepth = getFirst (maxDepth_ sig),-    summarySize = getFirst (maxSize_ sig),-    summaryTests = getFirst (minTests_ sig),-    summaryQuickCheckSize = getFirst (maxQuickCheckSize_ sig) }--  where-    symbols :: (Sig -> TypeRel f) -> (forall a. f a -> Symbol) -> [Symbol]-    symbols f erase = map (some erase) (TypeRel.toList (f sig))--    allConstants = symbols constants (sym . unConstant)-    allVariables = symbols variables (sym . unVariable)--data Observer a = forall b. Ord b => Observer (PGen (a -> b))--observe x sig =-  TypeMap.lookup (TypeMap.lookup (ERROR msg) x (ords sig))-               x (observers sig)-  where msg = "no observers found for type " ++ show (typeOf x)--emptySig :: Sig-emptySig = Sig TypeRel.empty TypeRel.empty TypeMap.empty TypeMap.empty TypeMap.empty TypeMap.empty TypeMap.empty mempty mempty mempty mempty--instance Monoid Sig where-  mempty = emptySig-  s1 `mappend` s2 =-    Sig {-      constants = renumber (mapConstant . alter) (length variables') constants',-      variables = renumber (mapVariable . alter) 0 variables',-      observers = observers s1 `mappend` observers s2,-      total = total s1 `mappend` total s2,-      partial = partial s1 `mappend` partial s2,-      ords = ords s1 `mappend` ords s2,-      witnesses = witnesses s1 `mappend` witnesses s2,-      maxDepth_ = maxDepth_ s1 `mappend` maxDepth_ s2,-      maxSize_ = maxSize_ s1 `mappend` maxSize_ s2,-      minTests_ = minTests_ s1 `mappend` minTests_ s2,-      maxQuickCheckSize_ = maxQuickCheckSize_ s1 `mappend` maxQuickCheckSize_ s2 }-    where constants' = TypeRel.toList (constants s1) ++-                       TypeRel.toList (constants s2)-          -- Overwrite variables if they're declared twice!-          variables' = TypeRel.toList (variables s1 `combine` variables s2)--          renumber :: (forall a. Int -> f a -> f a) ->-                      Int -> [Some f] -> TypeRel f-          renumber alter n =-            TypeRel.fromList .-            zipWith (\x -> mapSome (alter x)) [n..]--          alter :: Int -> Symbol -> Symbol-          alter n x = x { index = n }--          combine :: TypeRel Variable -> TypeRel Variable -> TypeRel Variable-          -- If a signature uses vars several times at the same type,-          -- the declaration with the highest number of variables "wins"-          -- and all others are discarded-          combine = Map.unionWith max_-            where max_ vs1 vs2-                    | some2 length vs1 > some2 length vs2 = vs1-                    | otherwise = vs2--constantSig :: Typeable a => Constant a -> Sig-constantSig x = emptySig { constants = TypeRel.singleton x }--variableSig :: forall a. Typeable a => [Variable a] -> Sig-variableSig x = emptySig { variables = TypeRel.fromList (map Some x) }--totalSig :: forall a. Typeable a => Gen a -> Sig-totalSig g = emptySig { total = TypeMap.singleton g }--partialSig :: forall a. Typeable a => Gen a -> Sig-partialSig g = emptySig { partial = TypeMap.singleton g }--observerSig :: forall a. Typeable a => Observer a -> Sig-observerSig x = emptySig { observers = TypeMap.singleton x }--typeSig :: Typeable a => a -> Sig-typeSig x = emptySig { witnesses = TypeMap.singleton (Witness x) }--ordSig :: Typeable a => Observer a -> Sig-ordSig x = emptySig { ords = TypeMap.singleton x }---- | If @withDepth n@ is in your signature,---   QuickSpec will consider terms of up to depth @n@---   (the default is 3).-withDepth :: Int -> Sig-withDepth n = updateDepth n emptySig---- | If @withSize n@ is in your signature,---   QuickSpec will consider terms of up to size @n@---   (the default is 100).-withSize :: Int -> Sig-withSize n = updateSize n emptySig---- | If @withTests n@ is in your signature,---   QuickSpec will run at least @n@ tests---   (the default is 500).-withTests :: Int -> Sig-withTests n = emptySig { minTests_ = First (Just n) }---- | If @withQuickCheckSize n@ is in your signature,---   QuickSpec will generate test data of up to size @n@---   (the default is 20).-withQuickCheckSize :: Int -> Sig-withQuickCheckSize n = emptySig { maxQuickCheckSize_ = First (Just n) }---- | @sig \`without\` xs@ will remove the functions---   in @xs@ from the signature @sig@.---   Useful when you want to use `Test.QuickSpec.prelude`---   but exclude some functions.---   Example: @`prelude` (undefined :: A) \`without\` [\"head\", \"tail\"]@.-without :: Signature a => a -> [String] -> Sig-without sig xs = sig' { constants = f p (constants sig'), variables = f q (variables sig') }-  where-    sig' = signature sig-    f p = TypeRel.fromList . filter p . TypeRel.toList-    p (Some (Constant k)) = name (sym k) `notElem` xs-    q (Some (Variable v)) = name (sym v) `notElem` xs--undefinedSig :: forall a. Typeable a => String -> a -> Sig-undefinedSig x u = constantSig (Constant (Atom ((symbol x 0 u) { undef = True }) u))--primCon0 :: forall a. Typeable a => Int -> String -> a -> Sig-primCon0 n x f = constantSig (Constant (Atom (symbol x n f) f))-                 `mappend` typeSig (undefined :: a)--primCon1 :: forall a b. (Typeable a, Typeable b) =>-          Int -> String -> (a -> b) -> Sig-primCon1 n x f = primCon0 n x f-                 `mappend` typeSig (undefined :: a)-                 `mappend` typeSig (undefined :: b)--primCon2 :: forall a b c. (Typeable a, Typeable b, Typeable c) =>-          Int -> String -> (a -> b -> c) -> Sig-primCon2 n x f = primCon1 n x f-                 `mappend` typeSig (undefined :: b)-                 `mappend` typeSig (undefined :: c)--primCon3 :: forall a b c d. (Typeable a, Typeable b, Typeable c, Typeable d) =>-          Int -> String -> (a -> b -> c -> d) -> Sig-primCon3 n x f = primCon2 n x f-                 `mappend` typeSig (undefined :: c)-                 `mappend` typeSig (undefined :: d)--primCon4 :: forall a b c d e. (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) =>-          Int -> String -> (a -> b -> c -> d -> e) -> Sig-primCon4 n x f = primCon3 n x f-                 `mappend` typeSig (undefined :: d)-                 `mappend` typeSig (undefined :: e)--primCon5 :: forall a b c d e f. (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) =>-          Int -> String -> (a -> b -> c -> d -> e -> f) -> Sig-primCon5 n x f = primCon4 n x f-                 `mappend` typeSig (undefined :: e)-                 `mappend` typeSig (undefined :: f)---- | A constant.-blind0 :: forall a. Typeable a => String -> a -> Sig-blind0 = primCon0 0--- | A unary function.-blind1 :: forall a b. (Typeable a, Typeable b) =>-          String -> (a -> b) -> Sig-blind1 = primCon1 1--- | A binary function.-blind2 :: forall a b c. (Typeable a, Typeable b, Typeable c) =>-          String -> (a -> b -> c) -> Sig-blind2 = primCon2 2--- | A ternary function.-blind3 :: forall a b c d. (Typeable a, Typeable b, Typeable c, Typeable d) =>-          String -> (a -> b -> c -> d) -> Sig-blind3 = primCon3 3--- | A function of arity 4.-blind4 :: forall a b c d e. (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) =>-          String -> (a -> b -> c -> d -> e) -> Sig-blind4 = primCon4 4--- | A function of arity 5.-blind5 :: forall a b c d e f. (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f) =>-          String -> (a -> b -> c -> d -> e -> f) -> Sig-blind5 = primCon5 5--ord :: (Ord a, Typeable a) => a -> Sig-ord x = ordSig (Observer (pgen (return id)) `observing` x)--observing :: Observer a -> a -> Observer a-observing x _ = x---- | Mark all the functions in a signature as background functions.------ QuickSpec will only print a law if it contains at least one non-background function.------ The functions in e.g. `Test.QuickSpec.prelude` are declared as background functions.-background :: Signature a => a -> Sig-background sig =-  sig' { constants = TypeRel.mapValues (mapConstant silence1) (constants sig'),-         variables = TypeRel.mapValues (mapVariable silence1) (variables sig') }-  where sig' = signature sig-        silence1 x = x { silent = True }--primVars0 :: forall a. Typeable a => Int -> [(String, PGen a)] -> Sig-primVars0 n xs = variableSig [ Variable (Atom (symbol x n (undefined :: a)) g) | (x, g) <- xs ]-             `mappend` mconcat [ totalSig (totalGen g) | (_, g) <- xs ]-             `mappend` mconcat [ partialSig (partialGen g) | (_, g) <- xs ]-             `mappend` typeSig (undefined :: a)--primVars1 :: forall a b. (Typeable a, Typeable b) => Int -> [(String, PGen (a -> b))] -> Sig-primVars1 n xs = primVars0 n xs-             `mappend` typeSig (undefined :: a)-             `mappend` typeSig (undefined :: b)--primVars2 :: forall a b c. (Typeable a, Typeable b, Typeable c) => Int -> [(String, PGen (a -> b -> c))] -> Sig-primVars2 n xs = primVars1 n xs-             `mappend` typeSig (undefined :: b)-             `mappend` typeSig (undefined :: c)---- | Similar to `vars`, but takes a generator as a parameter.------ @gvars xs (arbitrary :: Gen a)@ is the same as--- @vars xs (undefined :: a)@.-gvars, gvars0 :: forall a. Typeable a => [String] -> Gen a -> Sig-gvars xs g = primVars0 0 (zip xs (repeat (pgen g)))-gvars0 = gvars--gvars1 :: forall a b. (Typeable a, Typeable b) => [String] -> Gen (a -> b) -> Sig-gvars1 xs g = primVars1 1 (zip xs (repeat (pgen g)))--gvars2 :: forall a b c. (Typeable a, Typeable b, Typeable c) => [String] -> Gen (a -> b -> c) -> Sig-gvars2 xs g = primVars2 2 (zip xs (repeat (pgen g)))---- | For Hipsters only :)-gvars' :: forall a. Typeable a => [(String, Gen a)] -> Sig-gvars' xs = primVars0 0 [ (x, pgen g) | (x, g) <- xs ]---- | Declare a set of variables of a particular type.------ For example, @vars [\"x\",\"y\",\"z\"] (undefined :: Int)@--- defines three variables, @x@, @y@ and @z@, of type `Int`.-vars, vars0 :: forall a. (Arbitrary a, Typeable a) => [String] -> a -> Sig-vars xs _ = gvars xs (arbitrary :: Gen a)-vars0 = vars--vars1 :: forall a b. (CoArbitrary a, Typeable a, Arbitrary b, Typeable b) => [String] -> (a -> b) -> Sig-vars1 xs _ = gvars1 xs (arbitrary :: Gen (a -> b))--vars2 :: forall a b c. (CoArbitrary a, Typeable a, CoArbitrary b, Typeable b, Arbitrary c, Typeable c) => [String] -> (a -> b -> c) -> Sig-vars2 xs _ = gvars2 xs (arbitrary :: Gen (a -> b -> c))--con, fun0 :: (Ord a, Typeable a) => String -> a -> Sig--- | A constant. The same as `fun0`.-con = fun0--- | A constant. The same as `con`.-fun0 x f = blind0 x f-           `mappend` ord f---- | A unary function.-fun1 :: (Typeable a,-         Typeable b, Ord b) =>-        String -> (a -> b) -> Sig-fun1 x f = blind1 x f-           `mappend` ord (f undefined)---- | A binary function.-fun2 :: (Typeable a, Typeable b,-         Typeable c, Ord c) =>-        String -> (a -> b -> c) -> Sig-fun2 x f = blind2 x f-           `mappend` ord (f undefined undefined)---- | A ternary function.-fun3 :: (Typeable a, Typeable b, Typeable c,-         Typeable d, Ord d) =>-        String -> (a -> b -> c -> d) -> Sig-fun3 x f = blind3 x f-           `mappend` ord (f undefined undefined undefined)---- | A function of four arguments.-fun4 :: (Typeable a, Typeable b, Typeable c, Typeable d,-         Typeable e, Ord e) =>-        String -> (a -> b -> c -> d -> e) -> Sig-fun4 x f = blind4 x f-           `mappend` ord (f undefined undefined undefined undefined)---- | A function of five arguments.-fun5 :: (Typeable a, Typeable b, Typeable c, Typeable d,-         Typeable e, Typeable f, Ord f) =>-        String -> (a -> b -> c -> d -> e -> f) -> Sig-fun5 x f = blind5 x f-           `mappend` ord (f undefined undefined undefined undefined undefined)---- | An observation function of arity 1.-observer1 :: (Typeable a, Typeable b, Ord b) => (a -> b) -> Sig-observer1 f = observerSig (Observer (pgen (return f)))---- | An observation function of arity 2.-observer2 :: (Arbitrary a, Typeable a, Typeable b, Typeable c, Ord c) =>-             (a -> b -> c) -> Sig-observer2 f = observerSig (Observer (pgen (f <$> arbitrary)))---- | An observation function of arity 3.-observer3 :: (Arbitrary a, Arbitrary b,-              Typeable a, Typeable b, Typeable c, Typeable d,-              Ord d) =>-             (a -> b -> c -> d) -> Sig-observer3 f = observerSig (Observer (pgen (f <$> arbitrary <*> arbitrary)))---- | An observation function of arity 4.-observer4 :: (Arbitrary a, Arbitrary b, Arbitrary c,-              Typeable a, Typeable b, Typeable c, Typeable d, Typeable e,-              Ord e) =>-             (a -> b -> c -> d -> e) -> Sig-observer4 f = observerSig (Observer (pgen (f <$> arbitrary <*> arbitrary <*> arbitrary)))--testable :: Typeable a => Sig -> a -> Bool-testable sig x =-  typeOf x `Map.member` observers sig ||-  typeOf x `Map.member` ords sig---- Given a constant, find the types of its partial applications.-constantApplications :: forall a. Typeable a => Sig -> Constant a -> [Witness]-constantApplications sig (Constant (Atom {sym = sym })) =-  map (findWitness sig)-    (take (symbolArity sym + 1)-     (iterate rightArrow (typeOf (undefined :: a))))---- Find the argument types of a constant.-constantArgs :: forall a. Typeable a => Sig -> Constant a -> [Witness]-constantArgs sig (Constant (Atom { sym = sym })) =-  map (findWitness sig)-    (take (symbolArity sym)-     (unfoldr splitArrow (typeOf (undefined :: a))))---- Find the type of a saturated constant.-constantRes :: forall a. Typeable a => Sig -> Constant a -> Witness-constantRes sig (Constant (Atom { sym = sym })) =-  findWitness sig-    (iterate (snd . fromMaybe (ERROR msg) . splitArrow)-       (typeOf (undefined :: a)) !! symbolArity sym)-  where msg = "constantRes: type oversaturated"---- The set of types returned by saturated constants.-saturatedTypes :: Sig -> [Witness]-saturatedTypes sig =-  usort-    [ constantRes sig k-    | Some k <- TypeRel.toList (constants sig) ]---- The set of types of which there is a non-variable term.-inhabitedTypes :: Sig -> [Witness]-inhabitedTypes sig =-  usort . concat $-    [ constantApplications sig k-    | Some k <- TypeRel.toList (constants sig) ]---- The set of types that appear as arguments to functions.-argumentTypes :: Sig -> [Witness]-argumentTypes sig =-  usort . concat $-    [ constantArgs sig k-    | Some k <- TypeRel.toList (constants sig) ]---- The set of types inhabited by variables.-variableTypes :: Sig -> [Witness]-variableTypes sig =-  usort (map someWitness (TypeRel.toList (variables sig)))---- Given a type, find a witness that it's a function.-witnessArrow :: Typeable a => Sig -> a -> Maybe (Witness, Witness)-witnessArrow sig x = do-  (lhs, rhs) <- splitArrow (typeOf x)-  liftM2 (,) (lookupWitness sig lhs) (lookupWitness sig rhs)---- lhsWitnesses sig x is the set of witnessed function types that--- might accept x as a parameter. There is no guarantee that--- any particular type is inhabited.-lhsWitnesses :: Typeable a => Sig -> a -> [Witness]-lhsWitnesses sig x =-  [ lhs-  | Some (Witness w) <- TypeMap.toList (witnesses sig),-    Just (lhs, rhs) <- [witnessArrow sig w],-    witnessType rhs == typeOf x ]--findWitness :: Sig -> TypeRep -> Witness-findWitness sig ty = fromMaybe (ERROR "missing type") (lookupWitness sig ty)--lookupWitness :: Sig -> TypeRep -> Maybe Witness-lookupWitness sig ty = Map.lookup ty (witnesses sig)--disambiguate :: Sig -> [Symbol] -> Symbol -> Symbol-disambiguate sig ss =-  \x ->-    fromMaybe (ERROR "variable not found")-      (find (\y -> index x == index y)-        (aux [] (nub ss)))-  where-    aux used [] = []-    aux used (x:xs) = x { name = next }:aux (next:used) xs-      where next = head (filter (`notElem` used) candidates)-            candidates-              | null wellTypedNames = ERROR "null allVars"-              | otherwise = concat [ map (++ suffix) wellTypedNames | suffix <- suffixes ]-            allVars =-              map (some (sym . unVariable))-                (TypeRel.toList (variables sig)) ++-              ss-            wellTypedNames =-              [ name v | v <- allVars, symbolType v == symbolType x ]-            suffixes =-              concat ([sequence (replicate n ['a'..'z']) | n <- [0..]])--constantSymbols, variableSymbols, symbols :: Sig -> [Symbol]-constantSymbols sig =-  map (some (sym . unConstant)) (TypeRel.toList (constants sig))-variableSymbols sig =-  map (some (sym . unVariable)) (TypeRel.toList (variables sig))-symbols sig = constantSymbols sig ++ variableSymbols sig
− src/Test/QuickSpec/Term.hs 
@@ -1,210 +0,0 @@--- | Terms and evaluation.--{-# LANGUAGE CPP, RankNTypes, ExistentialQuantification, DeriveFunctor, DeriveDataTypeable #-}-module Test.QuickSpec.Term where--#include "errors.h"-import Test.QuickSpec.Utils.Typeable-import Test.QuickCheck-import Test.QuickCheck.Gen-import Test.QuickCheck.Gen.Unsafe-import Data.Function-import Data.Ord-import Data.Char-import Data.List-import Test.QuickSpec.Utils--data Symbol = Symbol {-  index :: Int,-  name :: String,-  symbolArity :: Int,-  silent :: Bool,-  undef :: Bool,-  symbolType :: TypeRep }--symbol :: Typeable a => String -> Int -> a -> Symbol-symbol x arity v = Symbol 0 x arity False False (typeOf v)--instance Show Symbol where-  show = showOp . name--instance Eq Symbol where-  (==) = (==) `on` index--instance Ord Symbol where-  compare = comparing index--data Term =-    Var Symbol-  | Const Symbol-  | App Term Term deriving Eq--infixl 5 `App`--instance Ord Term where-  compare = comparing stamp-    where-      stamp t = (depth t, size 0 t, -occur t, body t)--      occur t = length (usort (vars t))--      body (Var x) = Left (Left x)-      body (Const x) = Left (Right x)-      body (App f x) = Right (f, x)--instance Show Term where-  showsPrec p t = showString (showTerm p (hideImplicit t))-   where-     brack s = "(" ++ s ++ ")"-     parenFun p s | p < 2 = s-                  | otherwise = brack s-     parenOp p s | p < 1 = s-                 | otherwise = brack s--     showTerm p (Var v) = show v-     showTerm p (Const x) = show x-     showTerm p (Const op `App` x) | isOp (name op) =-       brack (showTerm 1 x ++ name op)-     showTerm p (Const op `App` x `App` y) | isOp (name op) =-       parenOp p (showTerm 1 x ++ name op ++ showTerm 1 y)--     showTerm p (f `App` x) =-       parenFun p (showTerm 1 f ++ " " ++ showTerm 2 x)--     hideImplicit (f `App` x)-       | isImplicit x = f-       | otherwise = hideImplicit f `App` hideImplicit x-     hideImplicit t = t--     isImplicit (Var v) | "_" `isPrefixOf` name v = True-     isImplicit _ = False--showOp :: String -> String-showOp op | isOp op = "(" ++ op ++ ")"-          | otherwise = op--isOp :: String -> Bool-isOp "[]" = False-isOp xs = not (all isIdent xs)-  where isIdent x = isAlphaNum x || x == '\'' || x == '_'--isUndefined :: Term -> Bool-isUndefined (Const Symbol { undef = True }) = True-isUndefined _ = False--symbols :: Term -> [Symbol]-symbols t = symbols' t []-  where symbols' (Var x) = (x:)-        symbols' (Const x) = (x:)-        symbols' (App f x) = symbols' f . symbols' x--depth :: Term -> Int-depth (App f x) = depth f `max` (1 + depth x)-depth _ = 1--size :: Int -> Term -> Int-size v (App f x) = size v f + size v x-size v (Var _) = v-size v (Const _) = 1--holes :: Term -> [(Symbol, Int)]-holes t = holes' 0 t []-  where holes' d (Var x) = ((x, d):)-        holes' d Const{} = id-        holes' d (App f x) = holes' d f . holes' (d+1) x--functor :: Term -> Symbol-functor (Var x) = x-functor (Const x) = x-functor (App f x) = functor f--args :: Term -> [Term]-args = reverse . args'-  where args' Var{} = []-        args' Const{} = []-        args' (App f x) = x:args' f--funs :: Term -> [Symbol]-funs t = aux t []-  where aux (Const x) = (x:)-        aux Var{} = id-        aux (App f x) = aux f . aux x--vars :: Term -> [Symbol]-vars t = aux t []-  where aux (Var x) = (x:)-        aux (App f x) = aux f . aux x-        aux Const{} = id--mapVars :: (Symbol -> Symbol) -> Term -> Term-mapVars f (Var x) = Var (f x)-mapVars f (Const x) = Const x-mapVars f (App t u) = App (mapVars f t) (mapVars f u)--mapConsts :: (Symbol -> Symbol) -> Term -> Term-mapConsts f (Var x) = Var x-mapConsts f (Const x) = Const (f x)-mapConsts f (App t u) = App (mapConsts f t) (mapConsts f u)--data Expr a = Expr {-  term :: Term,-  arity :: {-# UNPACK #-} !Int,-  eval :: Valuation -> a }-  deriving Typeable--instance Eq (Expr a) where-  (==) = (==) `on` term--instance Ord (Expr a) where-  compare = comparing term--instance Show (Expr a) where-  show = show . term--data Atom a = Atom {-  sym :: Symbol,-  value :: a } deriving Functor--data PGen a = PGen {-  totalGen :: Gen a,-  partialGen :: Gen a-  }--pgen :: Gen a -> PGen a-pgen g = PGen g g--type Strategy = forall a. Symbol -> PGen a -> Gen a--instance Functor PGen where-  fmap f (PGen tot par) = PGen (fmap f tot) (fmap f par)--newtype Variable a = Variable { unVariable :: Atom (PGen a) } deriving Functor-newtype Constant a = Constant { unConstant :: Atom a } deriving Functor--mapVariable :: (Symbol -> Symbol) -> Variable a -> Variable a-mapVariable f (Variable v) = Variable v { sym = f (sym v) }--mapConstant :: (Symbol -> Symbol) -> Constant a -> Constant a-mapConstant f (Constant v) = Constant v { sym = f (sym v) }---- Generate a random variable valuation-newtype Valuation = Valuation { unValuation :: forall a. Variable a -> a }--promoteVal :: (forall a. Variable a -> Gen a) -> Gen Valuation-promoteVal g = do-  Capture eval <- capture-  return (Valuation (eval . g))--valuation :: Strategy -> Gen Valuation-valuation strat = promoteVal (\(Variable x) -> index (sym x) `variant` strat (sym x) (value x))--var :: Variable a -> Expr a-var v@(Variable (Atom x _)) = Expr (Var x) (symbolArity x) (\env -> unValuation env v)--con :: Constant a -> Expr a-con (Constant (Atom x v)) = Expr (Const x) (symbolArity x) (const v)--app :: Expr (a -> b) -> Expr a -> Expr b-app (Expr t a f) (Expr u _ x)-  | a == 0 = ERROR "oversaturated function"-  | otherwise = Expr (App t u) (a - 1) (\env -> f env (x env))
− src/Test/QuickSpec/TestTotality.hs 
@@ -1,76 +0,0 @@--- | Test whether functions are total.---   Used by HipSpec.--{-# LANGUAGE CPP, TupleSections #-}-module Test.QuickSpec.TestTotality where--#include "errors.h"-import Prelude hiding (lookup)-import Test.QuickSpec.Reasoning.PartialEquationalReasoning hiding (Variable, total, partial)-import qualified Test.QuickSpec.Reasoning.PartialEquationalReasoning as PEQ-import Test.QuickSpec.Utils.TypeRel-import qualified Test.QuickSpec.Utils.TypeMap as TypeMap-import Test.QuickSpec.Utils.Typed-import Test.QuickSpec.Utils.Typeable-import Test.QuickSpec.Utils-import Test.QuickSpec.Signature-import Test.QuickSpec.Term hiding (symbols)-import Test.QuickCheck-import Test.QuickCheck.Gen-import Test.QuickCheck.Random-import System.Random-import Control.Monad-import Data.List hiding (lookup)-import Data.Maybe-import Data.Ord-import qualified Data.Map as Map--testTotality :: Sig -> IO [(Symbol, Totality)]-testTotality sig = do-  consts <- mapM (some constTotality) (toList (constants sig))-  let vars = map (some varTotality) (toList (variables sig))-  return (sortBy (comparing fst) (consts ++ vars))-  where-    constTotality :: Typeable a => Constant a -> IO (Symbol, Totality)-    constTotality (Constant x) = fmap (sym x,) (isTotal (symbolArity (sym x)) (value x))--    isTotal :: Typeable a => Int -> a -> IO Totality-    isTotal arity x = do-      b <- always sig (testTotal x [])-      if not b then return Partial-        else fmap Total . flip filterM [0..arity-1] $ \i -> always sig (testTotal x [i])--    testTotal :: Typeable a => a -> [Int] -> Gen Bool-    testTotal f args =-      case witnessArrow sig f of-        Nothing ->-          case observe undefined sig of-            Observer obs ->-              fmap (isJust . spoony) (liftM2 ($) (totalGen obs) (return f))-        Just (Some (Witness arg), Some (Witness res)) -> do-          if 0 `elem` args && typeOf res `Map.notMember` partial sig-            then return False-            else do-              x <- TypeMap.lookup __ arg-                   (if 0 `elem` args then partial sig else total sig)-              case cast f `asTypeOf` Just (\x -> (x `asTypeOf` arg) `seq` (undefined `asTypeOf` res)) of-                Just g -> testTotal (g x) (map pred args)--    varTotality :: Variable a -> (Symbol, Totality)-    varTotality (Variable x) = (sym x, PEQ.Variable)--testEquation :: Typeable a => Sig -> Expr a -> Expr a -> Symbol -> IO Bool-testEquation sig e1 e2 s =-  case observe undefined sig of-    Observer obs ->-      always sig $ do-        let strat s' = if s == s' then partialGen else totalGen-        obs' <- partialGen obs-        v <- valuation strat-        return (spoony (obs' (eval e1 v)) == spoony (obs' (eval e2 v)))--always :: Sig -> Gen Bool -> IO Bool-always sig x = do-  gens <- replicateM 100 newQCGen-  let sizes = cycle [0,2..maxQuickCheckSize sig]-  return (and [unGen x g n | (g, n) <- zip gens sizes])
− src/Test/QuickSpec/TestTree.hs 
@@ -1,112 +0,0 @@--- | A data structure to represent refining a set of terms into---   equivalence classes by testing.--{-# LANGUAGE CPP #-}-module Test.QuickSpec.TestTree(TestTree, terms, union, test,-               TestResults, cutOff, numTests, numResults,-               classes, reps, discrete) where--#include "errors.h"-import Data.List(sort)-import Test.QuickSpec.Utils-import Control.Exception(assert)---- Invariant: the children of a TestTree are sorted according to the--- parent's test. We exploit this in defining merge.------ A TestTree is always infinite, and branches t is always a--- refinement of t (it may be trivial, so that length (branches t) == 1).--- As a special case, a TestTree may be Nil, but Nil may not appear in--- the branches of a TestTree.-data TestTree a = Nil | NonNil (TestTree' a)-data TestTree' a = Tree { rep :: a, rest :: [a], branches :: [TestTree' a] }---- Precondition: bs must be sorted according to the TestCase.-tree :: Ord r => [a] -> (a -> r) -> [TestTree' a] -> TestTree' a-tree [] _ _ = ERROR "empty equivalence class"-tree (x:xs) eval bs =-  assert (isSortedBy (eval . rep) bs) $-    Tree { rep = x, rest = xs, branches = bs }--terms :: TestTree a -> [a]-terms Nil = []-terms (NonNil t) = terms' t--terms' :: TestTree' a -> [a]-terms' Tree{rep = x, rest = xs} = x:xs---- Precondition: the sequence of test cases given must be--- that used to generate the two TestTrees.-union :: Ord r => [a -> r] -> TestTree a -> TestTree a -> TestTree a-union _ Nil t = t-union _ t Nil = t-union evals (NonNil t1) (NonNil t2) = NonNil (union' evals t1 t2)--union' :: Ord r => [a -> r] -> TestTree' a -> TestTree' a -> TestTree' a-union' (eval:evals) t1 t2 =-  tree (terms' t1 ++ terms' t2) eval-         (merge (union' evals) (eval . rep) (branches t1) (branches t2))--test :: Ord r => [a -> r] -> [a] -> TestTree a-test _ [] = Nil-test tcs xs = NonNil (test' tcs xs)--test' :: Ord r => [a -> r] -> [a] -> TestTree' a-test' [] _ =-  error "Test.QuickSpec.TestTree.test': ran out of test cases"-test' (tc:tcs) [] =-  error "Test.QuickSpec.TestTree.test': found an empty equivalence class"-test' (tc:tcs) xs@[_] = tree xs tc [test' tcs xs]-test' (tc:tcs) xs = tree xs tc (map (test' tcs) bs)-  where bs = partitionBy tc xs---- A TestTree with finite depth, represented as a TestTree where some--- nodes have no branches. Since this breaks one of the TestTree--- invariants we use a different type.-newtype TestResults a = Results (TestTree a)--discrete :: Ord a => [a] -> TestResults a-discrete xs =-  case sort xs of-    [] -> Results Nil-    (y:ys) ->-      Results (NonNil (Tree y ys (map singleton (y:ys))))-      where singleton x = Tree x [] []--cutOff :: Int -> Int -> TestTree a -> TestResults a-cutOff _ _ Nil = Results Nil-cutOff m n (NonNil t) = Results (NonNil (aux m t))-  where aux _ t@Tree{rest = []} = t { branches = [] }-        aux 0 t = aux' False n n t-        aux m t = t { branches = map (aux (m-1)) (branches t) }-        -- Exponential backoff if we carry on refining a class-        aux' _ _ _ t@Tree{rest = []} = t { branches = [] }-        aux' True 0 n t = t { branches = map (aux' False (n*2-1) (n*2)) (branches t) }-        aux' False 0 n t = t { branches = [] }-        aux' x m n t@Tree{branches = [t']} = t { branches = [aux' x (m-1) n t'] }-        aux' _ m n t = t { branches = map (aux' True (m-1) n) (branches t) }--numTests :: TestResults a -> Int-numTests (Results Nil) = 0-numTests (Results (NonNil t)) = aux t-  where aux Tree{branches = []} = 0-        aux Tree{branches = bs} = 1 + maximum (map aux bs)--numResults :: TestResults a -> Int-numResults (Results Nil) = 0-numResults (Results (NonNil t)) = aux t-  where aux Tree{rest = []} = 0-        aux Tree{rest = xs, branches = ts} =-          1 + length xs + sum (map aux ts)--classes :: Ord a => TestResults a -> [[a]]-classes = sort . map sort . unsortedClasses--unsortedClasses :: TestResults a -> [[a]]-unsortedClasses (Results Nil) = []-unsortedClasses (Results (NonNil t)) = aux t-  where aux Tree{rep = x, rest = xs, branches = []} = [x:xs]-        aux Tree{branches = bs} = concatMap aux bs--reps :: Ord a => TestResults a -> [a]-reps = map head . classes
− src/Test/QuickSpec/Utils.hs 
@@ -1,50 +0,0 @@--- | Miscellaneous utility functions.--module Test.QuickSpec.Utils where--import Control.Arrow((&&&))-import Data.List(groupBy, sortBy, group, sort)-import Data.Ord(comparing)-import System.IO-import Control.Exception-import Control.Spoon--repeatM :: Monad m => m a -> m [a]-repeatM = sequence . repeat--partitionBy :: Ord b => (a -> b) -> [a] -> [[a]]-partitionBy value = map (map fst) . groupBy (\x y -> snd x == snd y) . sortBy (comparing snd) . map (id &&& value)--isSorted :: Ord a => [a] -> Bool-isSorted xs = and (zipWith (<=) xs (tail xs))--isSortedBy :: Ord b => (a -> b) -> [a] -> Bool-isSortedBy f xs = isSorted (map f xs)--usort :: Ord a => [a] -> [a]-usort = map head . group . sort--merge :: Ord b => (a -> a -> a) -> (a -> b) -> [a] -> [a] -> [a]-merge f c = aux-  where aux [] ys = ys-        aux xs [] = xs-        aux (x:xs) (y:ys) =-          case comparing c x y of-            LT -> x:aux xs (y:ys)-            GT -> y:aux (x:xs) ys-            EQ -> f x y:aux xs ys--orElse :: Ordering -> Ordering -> Ordering-EQ `orElse` x = x-x `orElse` _ = x--unbuffered :: IO a -> IO a-unbuffered x = do-  buf <- hGetBuffering stdout-  bracket_-    (hSetBuffering stdout NoBuffering)-    (hSetBuffering stdout buf)-    x--spoony :: Eq a => a -> Maybe a-spoony x = teaspoon ((x == x) `seq` x)
− src/Test/QuickSpec/Utils/MemoValuation.hs 
@@ -1,22 +0,0 @@--- | Memoise the variable valuation function for terms.---   In its own module because it's packed full of dangerous features!--{-# LANGUAGE Rank2Types #-}-module Test.QuickSpec.Utils.MemoValuation where--import Test.QuickSpec.Term-import Test.QuickSpec.Signature-import Data.Array hiding (index)-import Data.Array.Base(unsafeAt)-import Unsafe.Coerce-import GHC.Prim-import Test.QuickSpec.Utils.Typed-import Test.QuickSpec.Utils.TypeRel--memoValuation :: Sig -> Valuation -> Valuation-memoValuation sig (Valuation f) = Valuation (unsafeCoerce . unsafeAt arr . index . sym . unVariable)-  where arr :: Array Int Any-        arr = array (0, maximum (0:map (some (index . sym . unVariable)) vars))-                [(index (sym (unVariable v)), unsafeCoerce (f v))-                | Some v <- vars ]-        vars = toList (variables sig)
− src/Test/QuickSpec/Utils/TypeMap.hs 
@@ -1,38 +0,0 @@--- | A map from types to values.---   @'TypeMap' f@ maps each type @a@ to a value of type @f a@.--{-# LANGUAGE Rank2Types, TypeOperators #-}-module Test.QuickSpec.Utils.TypeMap where--import qualified Data.Map as Map-import Data.Map(Map)-import Test.QuickSpec.Utils.Typed-import Test.QuickSpec.Utils.Typeable--type TypeMap f = Map TypeRep (Some f)--empty :: TypeMap f-empty = fromList []--singleton :: Typeable a => f a -> TypeMap f-singleton x = fromList [Some x]--fromList :: [Some f] -> TypeMap f-fromList xs = Map.fromList [ (someType x, x) | x <- xs ]--toList :: TypeMap f -> [Some f]-toList = Map.elems--lookup :: Typeable a => f a -> a -> TypeMap f -> f a-lookup def x m =-  case Map.lookup (typeOf x) m of-    Nothing -> def-    Just (Some y) ->-      case gcast y of-        Just z -> z--mapValues :: (forall a. Typeable a => f a -> g a) -> TypeMap f -> TypeMap g-mapValues f = fmap (mapSome f)--mapValues2 :: (forall a. Typeable a => f (g a) -> h (i a)) -> TypeMap (f `O` g) -> TypeMap (h `O` i)-mapValues2 f = fmap (mapSome (O . f . unO))
− src/Test/QuickSpec/Utils/TypeRel.hs 
@@ -1,47 +0,0 @@--- | A relation between types and values.---   @'TypeRel' f@ relates each type @a@ to a set of values---   of type @f a@.--{-# LANGUAGE CPP, Rank2Types, TypeOperators #-}-module Test.QuickSpec.Utils.TypeRel where--#include "errors.h"-import qualified Test.QuickSpec.Utils.TypeMap as TypeMap-import Test.QuickSpec.Utils.TypeMap(TypeMap)-import Test.QuickSpec.Utils.Typed-import Test.QuickSpec.Utils.Typeable-import Data.Maybe-import Test.QuickSpec.Utils--type TypeRel f = TypeMap (List `O` f)--empty :: TypeRel f-empty = TypeMap.empty--singleton :: Typeable a => f a -> TypeRel f-singleton x = TypeMap.singleton (O [x])--fromList :: [Some f] -> TypeRel f-fromList = TypeMap.fromList . classify--toList :: TypeRel f -> [Some f]-toList = concatMap disperse . TypeMap.toList--lookup :: Typeable a => a -> TypeRel f -> [f a]-lookup x m = unO (TypeMap.lookup (O []) x m)--mapValues :: (forall a. Typeable a => f a -> g a) -> TypeRel f -> TypeRel g-mapValues f = TypeMap.mapValues2 (map f)--gather :: [Some f] -> Some (List `O` f)-gather [] = ERROR "empty list"-gather (Some x:xs) = Some (O (x:map gcast' xs))-  where gcast' (Some y) =-          fromMaybe (ERROR msg) (gcast y)-        msg = "heterogeneous list"--disperse :: Some (List `O` f) -> [Some f]-disperse (Some (O xs)) = map Some xs--classify :: [Some f] -> [Some (List `O` f)]-classify xs = map gather (partitionBy someType xs)
− src/Test/QuickSpec/Utils/Typeable.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction, CPP #-}---- | A wrapper around 'Data.Typeable', to work around:------   (1) The lack of an 'Ord' instance in older GHCs,------   (2) bug #5962 in new GHCs.--module Test.QuickSpec.Utils.Typeable(TypeRep, T.Typeable, T.Typeable1, T.Typeable2,-                typeOf, typeOf1, cast, gcast,-                mkTyConApp, typeRepTyCon, splitTyConApp,-                mkFunTy, unTypeRep) where--#if __GLASGOW_HASKELL__ >= 702-#define NEW_TYPEABLE-#endif--import qualified Data.Typeable as T-import Data.Ord-#ifndef NEW_TYPEABLE-import System.IO.Unsafe-#endif--newtype TypeRep = TypeRep { unTypeRep :: T.TypeRep }--instance Eq TypeRep where-  ty == ty' =-    unTypeRep ty == unTypeRep ty' ||-    ty `compare` ty' == EQ--#ifdef NEW_TYPEABLE-instance Ord TypeRep where-  compare = comparing splitTyConApp-#else-instance Ord TypeRep where-  compare = comparing (unsafePerformIO . T.typeRepKey . unTypeRep)-#endif--instance Show TypeRep where-  showsPrec p = showsPrec p . unTypeRep--typeOf = TypeRep . T.typeOf-typeOf1 = TypeRep . T.typeOf1-cast = T.cast-gcast = T.gcast--mkTyConApp f xs = TypeRep (T.mkTyConApp f (map unTypeRep xs))-typeRepTyCon = T.typeRepTyCon . unTypeRep-splitTyConApp ty = (c, map TypeRep tys)-  where (c, tys) = T.splitTyConApp (unTypeRep ty)-mkFunTy lhs rhs = TypeRep (T.mkFunTy (unTypeRep lhs) (unTypeRep rhs))
− src/Test/QuickSpec/Utils/Typed.hs 
@@ -1,91 +0,0 @@--- | Functions for working with existentially-quantified types---   and similar.--{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification, TypeOperators, TypeSynonymInstances, FlexibleInstances, PatternGuards #-}-module Test.QuickSpec.Utils.Typed where--#include "errors.h"-import Control.Monad-import Test.QuickSpec.Utils.Typeable-import Data.Ord-import Data.Function-import Data.Maybe-import Data.Typeable (TyCon)-import Test.QuickSpec.Utils (usort)--data Some f = forall a. Typeable a => Some (f a)--newtype O f g a = O { unO :: f (g a) }-type List = []--type Several f = Some (List `O` f)--newtype Witnessed a = Witness { witness :: a }-type Witness = Some Witnessed---- No Typeable (Witnessed a) instance to save accidentally looking up--- Witnessed a instead of a in a TypeMap--instance Eq Witness where-  (==) = (==) `on` witnessType--instance Ord Witness where-  compare = comparing witnessType--instance Show Witness where-  show = show . witnessType--witnessType :: Witness -> TypeRep-witnessType = some (typeOf . witness)--data Tagged a = Tagged { tag :: Witness, erase :: a }--tagged :: Typeable a => (f a -> b) -> f a -> Tagged b-tagged f x = Tagged (Some (Witness (witness x))) (f x)-  where witness :: f a -> a-        witness = undefined--some :: (forall a. Typeable a => f a -> b) -> Some f -> b-some f (Some x) = f x--several :: (forall a. Typeable a => [f a] -> b) -> Several f -> b-several f (Some (O xs)) = f xs--some2 :: (forall a. Typeable a => f (g a) -> b) -> Some (f `O` g) -> b-some2 f = some (f . unO)--mapSome :: (forall a. Typeable a => f a -> g a) -> Some f -> Some g-mapSome f (Some x) = Some (f x)--mapSome2 :: (forall a. Typeable a => f (g a) -> h (i a)) -> Some (f `O` g) -> Some (h `O` i)-mapSome2 f = mapSome (O . f . unO)--mapSomeM :: Monad m => (forall a. Typeable a => f a -> m (g a)) -> Some f -> m (Some g)-mapSomeM f (Some x) = liftM Some (f x)--someType :: Some f -> TypeRep-someType (Some x) = typeOf (witness x)-  where witness :: f a -> a-        witness = undefined--someWitness :: Some f -> Witness-someWitness = mapSome (const undefined)--splitArrow :: TypeRep -> Maybe (TypeRep, TypeRep)-splitArrow ty =-  case splitTyConApp ty of-    (c, [lhs, rhs]) | c == arr -> Just (lhs, rhs)-    _ -> Nothing-  where (arr, _) = splitTyConApp (typeOf (undefined :: Int -> Int))--rightArrow :: TypeRep -> TypeRep-rightArrow ty = snd (fromMaybe (ERROR msg) (splitArrow ty))-  where-    msg = "type oversaturated"--typeRepTyCons :: TypeRep -> [TyCon]-typeRepTyCons = usort . go where-  go ty-    | Just (t1,t2) <- splitArrow ty = go t1 ++ go t2-    | (ty_con,ts) <- splitTyConApp ty = ty_con:concatMap go ts-
− src/Test/QuickSpec/errors.h 
@@ -1,3 +0,0 @@--- Inspired by Agda's undefined.h-#define __ (ERROR "no error message given")-#define ERROR (\msg -> error ("Error at file " ++ __FILE__ ++ ", line " ++ show __LINE__ ++ ": " ++ msg))