├── .gitignore ├── .hgtags ├── .travis.yml ├── FUTURE.md ├── LICENSE ├── README.md ├── Setup.hs ├── changelog ├── examples ├── Arith.hs ├── ArithFloat.hs ├── Bicomplex.hs ├── Bools.hs ├── Composition.hs ├── Curry.hs ├── DecisionTrees.hs ├── Div.hs ├── GCD.hs ├── Geometry.hs ├── Heaps.hs ├── HugeLists.hs ├── HugeListsMono.hs ├── IntSet.hs ├── ListHOF.hs ├── ListMonad.hs ├── Lists.hs ├── Map.hs ├── Matrix.hs ├── Music │ ├── Music.lhs │ ├── MusicQS.hs │ ├── MusicQS1.hs │ └── Perform.lhs ├── Octonions.hs ├── OctonionsGroupy.hs ├── Parsec.hs ├── Parsing.hs ├── PrettyPrinting.hs ├── PrettyPrintingModel.hs ├── PrettyPrintingWadler.hs ├── Process.hs ├── Queues.hs ├── Regex.hs ├── Regex2.hs ├── Sorted.hs ├── TinyWM.hs ├── Zip.hs ├── tests │ ├── AC.hs │ ├── AC.output │ ├── Arith.output │ ├── ArithBackground.hs │ ├── ArithBackground.output │ ├── ArithFloat.output │ ├── Bicomplex.output │ ├── BinarySearch.output │ ├── Bools.output │ ├── Combinators.hs │ ├── Combinators.output │ ├── Composition-bad.hs │ ├── Composition-bad.output │ ├── Composition.output │ ├── Const.hs │ ├── Const.output │ ├── Curry.output │ ├── DecisionTrees.output │ ├── Div.output │ ├── GCD.output │ ├── Geometry.output │ ├── Head.hs │ ├── Head.output │ ├── Heaps.output │ ├── HugeLists.output │ ├── IntSet.output │ ├── ListHOF.output │ ├── ListMonad.output │ ├── Lists.output │ ├── MinMax.hs │ ├── Octonions.output │ ├── Pairs.hs │ ├── Pairs.output │ ├── PredicateBackground.hs │ ├── PredicateBackground.output │ ├── PrettyPrinting-warnings.hs │ ├── PrettyPrinting-warnings.output │ ├── PrettyPrinting.output │ ├── PrettyPrintingModel.output │ ├── Process.hs │ ├── Queues.output │ ├── Refinements.hs │ ├── Refinements.output │ ├── Sorted-typeclass.hs │ ├── Sorted-typeclass.output │ ├── Sorted.output │ ├── TinyWM.output │ ├── TypeClass.hs │ ├── TypeClass.output │ ├── Zip.output │ ├── run │ └── update └── weird │ ├── ConditionalsPruning.hs │ ├── DrawGeometry.hs │ ├── Exp.hs │ ├── GenericStuff.hs │ ├── Gyrogroup.hs │ ├── OctonionsComplicated.hs │ ├── Ords.hs │ ├── Table9Point1.hs │ └── Zipper.hs ├── notes ├── quickspec.cabal ├── src ├── QuickSpec.hs └── QuickSpec │ ├── Internal.hs │ └── Internal │ ├── Explore.hs │ ├── Explore │ ├── Conditionals.hs │ ├── Polymorphic.hs │ ├── Schemas.hs │ └── Terms.hs │ ├── Haskell.hs │ ├── Haskell │ └── Resolve.hs │ ├── Parse.hs │ ├── Prop.hs │ ├── Pruning.hs │ ├── Pruning │ ├── Background.hs │ ├── Conditionals.hs │ ├── PartialApplication.hs │ ├── Twee.hs │ ├── Types.hs │ └── UntypedTwee.hs │ ├── Term.hs │ ├── Terminal.hs │ ├── Testing.hs │ ├── Testing │ ├── DecisionTree.hs │ └── QuickCheck.hs │ ├── Type.hs │ └── Utils.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw* 2 | /dist 3 | cabal.sandbox.config 4 | .cabal-sandbox/ 5 | .stack-work/ 6 | bugs/ 7 | examples/Arith 8 | examples/ArithFloat 9 | examples/Bicomplex 10 | examples/Bools 11 | examples/Composition 12 | examples/Curry 13 | examples/Div 14 | examples/GCD 15 | examples/Geometry 16 | examples/Heaps 17 | examples/HugeLists 18 | examples/HugeListsMono 19 | examples/IntSet 20 | examples/ListHOF 21 | examples/ListMonad 22 | examples/Lists 23 | examples/Octonions 24 | examples/OctonionsGroupy 25 | examples/Parsing 26 | examples/PrettyPrinting 27 | examples/PrettyPrintingModel 28 | examples/Queues 29 | examples/QuickSpecConditionalBenchmarks/ 30 | examples/Regex 31 | examples/Sorted 32 | examples/TinyWM 33 | examples/Zip 34 | examples/tests/AC 35 | examples/tests/ArithFloat 36 | examples/tests/Combinators 37 | examples/tests/Composition-bad 38 | examples/tests/Const 39 | examples/tests/Head 40 | examples/tests/MinMax 41 | examples/tests/Pairs 42 | examples/tests/PrettyPrinting-warnings 43 | examples/tests/Refinements 44 | examples/tests/Sorted-typeclass 45 | examples/tests/TypeClass 46 | examples/old-examples 47 | hacking-guide/ 48 | statem-laws/ 49 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | c0a00e2e73609ba19932f99f11291d07cea9fa0b 2.1.3 2 | 52013eb24df8a79e041ca262707d050e592ce929 2.1.4 3 | dd3e3d99c6425f3127cdc4305be04d801b1f7f2c 2.1.5 4 | 27442ba21db974440f5dd0fa10434de33e4451b4 2.2 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Adapted from 2 | # https://raw.githubusercontent.com/commercialhaskell/stack/master/doc/travis-simple.yml 3 | 4 | sudo: false 5 | 6 | language: c 7 | 8 | cache: 9 | directories: 10 | - $HOME/.stack 11 | 12 | before_install: 13 | - mkdir -p ~/.local/bin 14 | - export PATH=$HOME/.local/bin:$PATH 15 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 16 | 17 | install: 18 | - stack --no-terminal install 19 | 20 | script: 21 | - GHC="stack exec -- ghc" examples/tests/run 22 | -------------------------------------------------------------------------------- /FUTURE.md: -------------------------------------------------------------------------------- 1 | # Future Work 2 | 3 | * Type class constraints in functions 4 | 5 | * Polymorphic application of functions (i.e. find natural transformations) 6 | 7 | * Relations 8 | 9 | * Imperative programs 10 | 11 | ## Small TODOs 12 | 13 | * Hide output of background theories 14 | - Can we safely disable (or limit) completion with background 15 | theories? 16 | - Explore background theories up to a smaller size 17 | - Remember the set of terms and add to it 18 | 19 | * Add QS1 feature of organising laws by defining function 20 | (i.e., "this is a law about BLAH") 21 | 22 | * Improve handling of partial functions (see Heaps.hs) 23 | 24 | * Make Type into an abstract type 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009-2018, Nick Smallbone 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Nick Smallbone nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | QuickSpec: equational laws for free! 2 | ==================================== 3 | 4 | QuickSpec takes your Haskell code and, as if by magic, discovers laws about it. 5 | You give QuickSpec a collection of Haskell functions; QuickSpec tests your functions 6 | with QuickCheck and prints out laws which seem to hold. 7 | 8 | For example, give QuickSpec the functions `reverse`, `++` and `[]`, and it will 9 | find six laws: 10 | 11 | ```haskell 12 | reverse [] == [] 13 | xs ++ [] == xs 14 | [] ++ xs == xs 15 | reverse (reverse xs) == xs 16 | (xs ++ ys) ++ zs == xs ++ (ys ++ zs) 17 | reverse xs ++ reverse ys == reverse (ys ++ xs) 18 | ``` 19 | 20 | QuickSpec can find equational laws as well as conditional equations. All you 21 | need to supply are the functions to test, as well as `Ord` and `Arbitrary` 22 | instances for QuickSpec to use in testing; the rest is automatic. 23 | 24 | For information on how to use QuickSpec, see 25 | [the documentation](http://hackage.haskell.org/package/quickspec/docs/QuickSpec.html). 26 | You can also look in the `examples` directory, for example at 27 | `List.hs`, `IntSet.hs`, or `Parsing.hs`. To read about how QuickSpec works, see 28 | our paper, [Quick specifications for the busy programmer](http://www.cse.chalmers.se/~nicsma/papers/quickspec2.pdf). 29 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | QuickSpec 2.2 (released 2023-09-21) 2 | * Compatibility with more recent GHC versions. 3 | * 'generator' for defining a custom generator for a particular data type. 4 | * 'withMaxFunctions' for limiting the maximum number of function 5 | symbols per term. 6 | * 'withConsistencyCheck' (experimental) for reporting when the 7 | discovered laws imply a false law. 8 | * Improvements to pruning. 9 | 10 | QuickSpec 2.1.5 (released 2020-08-31) 11 | * Give =~= an explicit fixity (thanks to Sandy Maguire). 12 | * More Observe instances (thanks to Sandy Maguire). 13 | 14 | QuickSpec 2.1.4 (released 2020-07-17) 15 | * Compatibility with random-1.2.0.0. 16 | 17 | QuickSpec 2.1.3 (released 2020-07-16) 18 | * 'variableUse' for limiting how variables can appear in a term. 19 | * TypeApplication-friendly combinators (thanks to Sandy Maguire). 20 | * '=~=' for using Observe in QuickCheck properties 21 | (thanks to Sandy Maguire). 22 | * 'withPrintStyle' for printing out laws as QuickCheck properties 23 | (thanks to Sandy Maguire). 24 | * Bug fixes. 25 | 26 | QuickSpec 2.1.2 (released 2019-08-20) 27 | 28 | * Implementation changes. 29 | 30 | QuickSpec 2.1.1 (released 2019-04-05) 31 | ------------------------------------- 32 | 33 | * Builds on GHC 7.10. 34 | * Better presentation of discovered equations. 35 | * Prints a warning when Ord or Arbitrary instances are missing. 36 | * Limited support for partial functions. 37 | * Experimental support for type class polymorphism. 38 | * Numerous bug fixes. 39 | 40 | QuickSpec 2 (released 2018-02-23) 41 | --------------------------------- 42 | 43 | New, much better version of QuickSpec. 44 | -------------------------------------------------------------------------------- /examples/Arith.hs: -------------------------------------------------------------------------------- 1 | -- A simple example testing arithmetic functions. 2 | import QuickSpec 3 | 4 | main = quickSpec [ 5 | con "0" (0 :: Int), 6 | con "1" (1 :: Int), 7 | con "+" ((+) :: Int -> Int -> Int), 8 | con "*" ((*) :: Int -> Int -> Int) ] 9 | -------------------------------------------------------------------------------- /examples/ArithFloat.hs: -------------------------------------------------------------------------------- 1 | -- Shows the use of the 'withConsistencyCheck' function. 2 | -- Here, QuickSpec discovers false laws, but withConsistencyCheck 3 | -- produces a warning for them. 4 | 5 | import QuickSpec 6 | import Test.QuickCheck 7 | 8 | main = quickSpec [ 9 | monoType (Proxy :: Proxy Float), 10 | withMaxTests 10000, 11 | withConsistencyCheck, 12 | 13 | con "0" (0 :: Float), 14 | con "1" (1 :: Float), 15 | con "+" ((+) :: Float -> Float -> Float), 16 | con "*" ((*) :: Float -> Float -> Float), 17 | con "/" ((/) :: Float -> Float -> Float) ] 18 | -------------------------------------------------------------------------------- /examples/Bicomplex.hs: -------------------------------------------------------------------------------- 1 | -- Note: we'd like to find zero divisor laws of the form t*u = 0. 2 | -- QuickSpec finds e.g. 3 | -- 20. (x + ih) * (1 + ih) = (x + 1) * (1 + ih) 4 | -- where setting x=-1 makes the RHS 0, but we'd like to find 5 | -- (-1 + ih) * (1 + ih) = 0 6 | -- Maybe use templates here? 7 | -- 8 | -- A simple example testing arithmetic functions. 9 | {-# LANGUAGE TupleSections #-} 10 | import QuickSpec 11 | import QuickSpec.Internal 12 | import qualified QuickSpec.Internal.Haskell as Haskell 13 | import Test.QuickCheck 14 | import Twee.Pretty 15 | import Control.Monad 16 | 17 | data BiComplex = B Rational Rational Rational Rational 18 | deriving (Eq, Ord, Show) 19 | 20 | instance Arbitrary BiComplex where 21 | arbitrary = 22 | resize 2 $ do 23 | n <- choose (0, 4) 24 | elts <- take n <$> shuffle [0..3] 25 | let 26 | arb0 i 27 | | i `elem` elts = oneof [arbitrary, elements [1, -1, 1/3, -1/3]] 28 | | otherwise = return 0 29 | liftM4 B (arb0 0) (arb0 1) (arb0 2) (arb0 3) 30 | 31 | instance Num BiComplex where 32 | fromInteger n = B (fromInteger n) 0 0 0 33 | negate (B r i h ih) = B (-r) (-i) (-h) (-ih) 34 | B r1 i1 h1 ih1 + B r2 i2 h2 ih2 = 35 | B (r1+r2) (i1+i2) (h1+h2) (ih1+ih2) 36 | B r1 i1 h1 ih1 * B r2 i2 h2 ih2 = 37 | B r i h ih 38 | where 39 | r = r1*r2 - i1*i2 - h1*h2 + ih1*ih2 40 | i = r1*i2 + r2*i1 - h1*ih2 - h2*ih1 41 | h = r1*h2 + r2*h1 - i1*ih2 - i2*ih1 42 | ih = r1*ih2 + r2*ih1 + i1*h2 + i2*h1 43 | 44 | i, h :: BiComplex 45 | i = B 0 1 0 0 46 | h = B 0 0 1 0 47 | 48 | conj1, conj2, conj3 :: BiComplex -> BiComplex 49 | conj1 (B r i h ih) = B r (-i) h (-ih) 50 | conj2 (B r i h ih) = B r i (-h) (-ih) 51 | conj3 = conj1 . conj2 52 | norm1, norm2 :: BiComplex -> BiComplex 53 | norm1 x = x * conj1 x 54 | norm2 x = x * conj2 x 55 | 56 | isReal (B _ 0 0 0) = True 57 | isReal _ = False 58 | 59 | genReal = do 60 | B x _ _ _ <- arbitrary 61 | return (B x 0 0 0) 62 | 63 | isDuplex (B _ 0 0 _) = True 64 | isDuplex _ = False 65 | 66 | genDuplex = do 67 | B x _ _ y <- arbitrary 68 | return (B x 0 0 y) 69 | 70 | main = quickSpec [ 71 | withMaxTermSize 7, 72 | -- withMaxTests 10000, 73 | monoType (Proxy :: Proxy BiComplex), 74 | series [ 75 | [con "0" (0 :: BiComplex), 76 | con "1" (1 :: BiComplex), 77 | -- con "+" ((+) :: BiComplex -> BiComplex -> BiComplex), 78 | con "-" (negate :: BiComplex -> BiComplex), 79 | con "*" ((*) :: BiComplex -> BiComplex -> BiComplex)], 80 | [con "real" isReal, 81 | -- con "duplex" isDuplex, 82 | con "True" True], 83 | --predicateGen "duplex" isDuplex (\() -> do { x <- genDuplex; return (x, ()) })], 84 | [con "conj1" conj1, 85 | con "conj2" conj2, 86 | con "conj3" conj3], 87 | [con "norm1" norm1, 88 | con "norm2" norm2], 89 | [con "10" (10 :: BiComplex)], 90 | [--con "-1" (-1 :: BiComplex), 91 | con "i" (i :: BiComplex), 92 | con "h" (h :: BiComplex), 93 | con "ih" (i * h :: BiComplex)]]] 94 | -------------------------------------------------------------------------------- /examples/Bools.hs: -------------------------------------------------------------------------------- 1 | -- Testing functions on booleans. "not x" is used as a condition. 2 | import QuickSpec 3 | 4 | main = quickSpec [ 5 | predicate "not" not, 6 | con "True" True, 7 | con "False" False, 8 | con "||" (||), 9 | con "&&" (&&) ] 10 | -------------------------------------------------------------------------------- /examples/Composition.hs: -------------------------------------------------------------------------------- 1 | -- Function composition. 2 | import QuickSpec 3 | 4 | main = quickSpec [ 5 | con "id" (id :: A -> A), 6 | con "." ((.) :: (B -> C) -> (A -> B) -> A -> C) ] 7 | -------------------------------------------------------------------------------- /examples/Curry.hs: -------------------------------------------------------------------------------- 1 | import QuickSpec 2 | 3 | main = quickSpec [ 4 | con "curry" (curry :: ((A, B) -> C) -> A -> B -> C), 5 | con "fst" (fst :: (A, B) -> A), 6 | con "snd" (snd :: (A, B) -> B), 7 | con "id" (id :: A -> A), 8 | con "." ((.) :: (B -> C) -> (A -> B) -> A -> C), 9 | con "|" ((\f g x -> (f x, g x)) :: (A -> B) -> (A -> C) -> A -> (B, C))] 10 | -------------------------------------------------------------------------------- /examples/DecisionTrees.hs: -------------------------------------------------------------------------------- 1 | module DecisionTrees where 2 | 3 | import QuickSpec 4 | import Test.QuickCheck 5 | import Data.List 6 | import Data.Ord 7 | import qualified Data.Set as Set 8 | import Data.Set(Set) 9 | 10 | data Tree d a = 11 | Leaf a 12 | | Choice d (Tree d a) (Tree d a) 13 | deriving Show 14 | 15 | instance (Arbitrary a, Arbitrary d) => Arbitrary (Tree d a) where 16 | arbitrary = sized arb 17 | where 18 | arb 0 = Leaf <$> arbitrary 19 | arb n = Choice <$> arbitrary <*> arb' <*> arb' 20 | where 21 | arb' = arb (n `div` 2) 22 | 23 | class Ord d => Decision d where 24 | conj :: [d] -> d 25 | neg :: d -> d 26 | 27 | disj :: Decision d => [d] -> d 28 | disj = neg . conj . map neg 29 | 30 | true, false :: Decision d => d 31 | true = conj [] 32 | false = neg true 33 | 34 | flatten :: Decision d => Tree d a -> [(d, a)] 35 | flatten t = flat true t [] 36 | where 37 | flat d (Leaf x) xs 38 | | d == false = xs 39 | | otherwise = (d, x):xs 40 | flat d (Choice d' t u) xs = 41 | flat (conj [d, d']) t $ 42 | flat (conj [d, neg d']) u xs 43 | 44 | instance (Decision d, Ord a) => Eq (Tree d a) where 45 | t == u = compare t u == EQ 46 | 47 | instance (Decision d, Ord a) => Ord (Tree d a) where 48 | compare = comparing (sort . flatten) 49 | 50 | class Finite a where 51 | univ :: Set a 52 | 53 | newtype Five = Five Int 54 | deriving (Eq, Ord, Show) 55 | 56 | instance Arbitrary Five where 57 | arbitrary = elements (Set.toList univ) 58 | 59 | instance Finite Five where 60 | univ = Set.fromList (map Five [1..5]) 61 | 62 | instance (Finite a, Ord a) => Decision (Set a) where 63 | conj [] = univ 64 | conj (x:xs) = x `Set.intersection` conj xs 65 | neg x = univ Set.\\ x 66 | 67 | main = 68 | quickSpec [ 69 | withMaxTermSize 9, 70 | monoTypeWithVars ["t", "u", "v"] (Proxy :: Proxy (Tree (Set Five) Int)), 71 | monoTypeWithVars ["p", "q", "r"] (Proxy :: Proxy (Set Five)), 72 | series 73 | [[con "true" (true :: Set Five), 74 | con "false" (false :: Set Five), 75 | --con "neg" (neg :: Set Five -> Set Five), 76 | con "&" (\x y -> conj [x, y] :: Set Five), 77 | predicate "isSubsetOf" (\x y -> conj [x, y] == (x :: Set Five))], 78 | --con "|" (\x y -> disj [x, y] :: Set Five) 79 | [--con "Leaf" (Leaf :: Int -> Tree (Set Five) Int), 80 | con "Choice" (Choice :: Set Five -> Tree (Set Five) Int -> Tree (Set Five) Int -> Tree (Set Five) Int)]]] 81 | -------------------------------------------------------------------------------- /examples/Div.hs: -------------------------------------------------------------------------------- 1 | -- A simple example testing arithmetic functions. 2 | import QuickSpec 3 | import QuickSpec.Internal 4 | import Test.QuickCheck 5 | 6 | ceildiv :: Integer -> Integer -> Integer 7 | ceildiv x y = x `div` y + (if x `mod` y == 0 then 0 else 1) 8 | 9 | rounddiv :: Integer -> Integer -> Integer 10 | rounddiv x y = (x `ceildiv` y) * y 11 | 12 | main = quickSpec [ 13 | instFun (arbitrary `suchThat` (> 0) :: Gen Integer), 14 | withConsistencyCheck, 15 | background [ 16 | con "1" (1 :: Integer), 17 | con "+" ((+) :: Integer -> Integer -> Integer), 18 | con "*" ((*) :: Integer -> Integer -> Integer), 19 | predicate "<=" ((<=) :: Integer -> Integer -> Bool) ], 20 | series [ 21 | con "rounddiv" rounddiv, 22 | con "ceildiv" ceildiv ]] 23 | -------------------------------------------------------------------------------- /examples/GCD.hs: -------------------------------------------------------------------------------- 1 | -- A simple example testing arithmetic functions. 2 | import QuickSpec 3 | import Numeric.Natural 4 | 5 | main = quickSpec [ 6 | series [ 7 | [con "0" (0 :: Natural), 8 | con "1" (1 :: Natural), 9 | con "+" ((+) :: Natural -> Natural -> Natural), 10 | con "*" ((*) :: Natural -> Natural -> Natural)], 11 | [con "gcd" (gcd :: Natural -> Natural -> Natural)]]] 12 | -------------------------------------------------------------------------------- /examples/Geometry.hs: -------------------------------------------------------------------------------- 1 | -- Henderson's functional geometry. See the QuickSpec paper. 2 | -- 3 | -- Illustrates: 4 | -- * Observational equality 5 | -- * Running QuickSpec on a progressively larger set of signatures 6 | {-# LANGUAGE DeriveDataTypeable, TypeOperators, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} 7 | import QuickSpec 8 | import Test.QuickCheck 9 | import qualified Data.Set as Set 10 | import Data.Set(Set) 11 | import Prelude hiding (flip, cycle) 12 | import Data.Monoid 13 | import Control.Monad 14 | import Data.Word 15 | import Data.Constraint 16 | 17 | -- We use our own number type for efficiency purposes. 18 | -- This can represent numbers of the form x/2^e where x and e are integers. 19 | data Rat = Rat { mantissa :: Integer, exponent :: Int } deriving (Eq, Ord, Show, Typeable) 20 | -- Rat x e = x / 2^e 21 | 22 | rat :: Integer -> Int -> Rat 23 | rat x e | e < 0 = error "rat: negative exponent" 24 | rat x 0 = Rat x 0 25 | rat x e | even x = rat (x `div` 2) (e-1) 26 | rat x e = Rat x e 27 | 28 | instance Arbitrary Rat where 29 | arbitrary = liftM2 rat arbitrary (choose (0, 10)) 30 | shrink (Rat x e) = fmap (uncurry rat) (shrink (x, e)) 31 | 32 | instance CoArbitrary Rat where 33 | coarbitrary (Rat x e) = coarbitrary x . coarbitrary e 34 | 35 | -- A class for types (like Rat) which can be added, subtracted and 36 | -- divided by 2. 37 | class Half a where 38 | zero :: a 39 | neg :: a -> a 40 | plus :: a -> a -> a 41 | half :: a -> a 42 | 43 | instance Half Rat where 44 | zero = rat 0 0 45 | neg (Rat x e) = Rat (negate x) e 46 | plus (Rat x1 e1) (Rat x2 e2) = 47 | rat (x1 * 2^(e - e1) + x2 * 2^(e - e2)) e 48 | where 49 | e = e1 `max` e2 50 | half (Rat x e) = Rat x (e+1) 51 | 52 | instance (Half a, Half b) => Half (a, b) where 53 | zero = (zero, zero) 54 | neg (x, y) = (neg x, neg y) 55 | plus (x, y) (z, w) = (plus x z, plus y w) 56 | half (x, y) = (half x, half y) 57 | 58 | -- A vector is a pair of points. 59 | type Vector = (Rat, Rat) 60 | 61 | -- We represent a geometrical object as a triple of vectors. 62 | -- I forget what they mean :) 63 | -- I think two of them represent the direction of the x-axis and y-axis. 64 | -- The word represents an abstract "drawing command". 65 | type Object = (Vector, Vector, Vector, Word) 66 | 67 | -- A drawing takes size and rotation information and returns a set of objects. 68 | newtype Drawing = Drawing (Vector -> Vector -> Vector -> Objs) deriving Typeable 69 | newtype Objs = Objs { unObjs :: Set Object } deriving (Eq, Ord, Typeable, Show) 70 | instance Arbitrary Objs where arbitrary = fmap objs arbitrary 71 | 72 | objs :: Set Object -> Objs 73 | objs = Objs . Set.filter (\(_,b,c,_) -> b /= zero && c /= zero) 74 | 75 | instance Show Drawing where 76 | show (Drawing x) = show (x one one one) 77 | where 78 | one = (Rat 1 0, Rat 1 0) 79 | 80 | instance Arbitrary Drawing where 81 | arbitrary = do 82 | os <- arbitrary 83 | return . Drawing $ \x y z -> objs (Set.fromList [(x, y, z, o) | o <- os]) 84 | shrink (Drawing f) = 85 | [ Drawing $ \x y z -> objs (Set.fromList [(x, y, z, o) | o <- objs']) 86 | | let os = [ o | (_, _, _, o) <- Set.toList (unObjs (f one one one)) ], 87 | objs' <- shrink os ] 88 | where 89 | one = (Rat 1 0, Rat 1 0) 90 | 91 | blank :: Drawing 92 | blank = Drawing (\_ _ _ -> objs Set.empty) 93 | 94 | -- The primed versions of the combinators are buggy 95 | over, beside, above, above' :: Drawing -> Drawing -> Drawing 96 | over (Drawing p) (Drawing q) = Drawing (\a b c -> p a b c `union` q a b c) 97 | beside (Drawing p) (Drawing q) = Drawing (\a b c -> p a (half b) c `union` q (a `plus` half b) (half b) c) 98 | above' (Drawing p) (Drawing q) = Drawing (\a b c -> p a b (half c) `union` q (a `plus` half c) b (half c)) 99 | above (Drawing p) (Drawing q) = Drawing (\a b c -> p (a `plus` half c) b (half c) `union` q a b (half c)) 100 | 101 | union :: Objs -> Objs -> Objs 102 | union (Objs x) (Objs y) = objs (x `Set.union` y) 103 | 104 | rot, flip, rot45 :: Drawing -> Drawing 105 | rot (Drawing p) = Drawing (\a b c -> p (a `plus` b) c (neg b)) 106 | flip (Drawing p) = Drawing (\a b c -> p (a `plus` b) (neg b) c) 107 | rot45 (Drawing p) = Drawing (\a b c -> p (a `plus` half (b `plus` c)) (half (b `plus` c)) (half (c `plus` neg b))) 108 | 109 | quartet, quartet' :: Drawing -> Drawing -> Drawing -> Drawing -> Drawing 110 | quartet a b c d = (a `beside` b) `above` (c `beside` d) 111 | quartet' a b c d = (a `beside` b) `above'` (c `beside` d) 112 | 113 | cycle, cycle' :: Drawing -> Drawing 114 | cycle x = quartet x (rot (rot (rot x))) (rot x) (rot (rot x)) 115 | cycle' x = quartet' x (rot (rot (rot x))) (rot x) (rot (rot x)) 116 | 117 | -- Observational equality for drawings. 118 | instance Observe (Vector, Vector, Vector) Objs Drawing where 119 | observe (a, b, c) (Drawing d) = d a b c 120 | 121 | main = 122 | quickSpec [ 123 | inst (Sub Dict :: () :- Arbitrary Drawing), 124 | inst (Sub Dict :: () :- Observe (Vector, Vector, Vector) Objs Drawing), 125 | series [sig1, sig2, sig3, sig4, sig5, sig6, sig7] ] 126 | where 127 | -- A series of bigger and bigger signatures. 128 | sig1 = [con "over" over] 129 | sig2 = [ 130 | con "beside" beside, 131 | -- con "above" above', 132 | con "above" above] 133 | sig3 = [con "rot" rot] 134 | sig4 = [con "flip" flip] 135 | sig5 = [ 136 | con "cycle" cycle, 137 | -- con "cycle" cycle', 138 | con "quartet" quartet] 139 | sig6 = [con "rot45" rot45] 140 | sig7 = [con "blank" blank] 141 | -------------------------------------------------------------------------------- /examples/Heaps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} 2 | 3 | import Prelude hiding (null) 4 | import QuickSpec 5 | import Test.QuickCheck 6 | import Test.QuickCheck.Poly(OrdA(..)) 7 | import Data.Ord 8 | import qualified Data.List as L 9 | 10 | data Heap a = Nil | Branch Int a (Heap a) (Heap a) deriving Typeable 11 | 12 | instance Ord a => Eq (Heap a) where 13 | h1 == h2 = toList h1 == toList h2 14 | 15 | instance Ord a => Ord (Heap a) where 16 | compare = comparing toList 17 | 18 | instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where 19 | arbitrary = fmap fromList arbitrary 20 | 21 | toList :: Ord a => Heap a -> [a] 22 | toList h | null h = [] 23 | | otherwise = findMin h:toList (deleteMin h) 24 | 25 | fromList :: Ord a => [a] -> Heap a 26 | fromList = foldr insert Nil 27 | 28 | null :: Heap a -> Bool 29 | null Nil = True 30 | null _ = False 31 | 32 | findMin :: Heap a -> a 33 | findMin (Branch _ x _ _) = x 34 | 35 | insert :: Ord a => a -> Heap a -> Heap a 36 | insert x h = merge h (branch x Nil Nil) 37 | 38 | deleteMin :: Ord a => Heap a -> Heap a 39 | deleteMin (Branch _ _ l r) = merge l r 40 | 41 | branch :: Ord a => a -> Heap a -> Heap a -> Heap a 42 | branch x l r | npl l <= npl r = Branch (npl l + 1) x l r 43 | | otherwise = Branch (npl r + 1) x r l 44 | 45 | merge :: Ord a => Heap a -> Heap a -> Heap a 46 | merge Nil h = h 47 | merge h Nil = h 48 | merge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2) 49 | | x1 <= x2 = branch x1 (merge l1 h2) r1 50 | | otherwise = merge h2 h1 51 | 52 | npl :: Heap a -> Int 53 | npl Nil = 0 54 | npl (Branch n _ _ _) = n 55 | 56 | mergeLists :: Ord a => [a] -> [a] -> [a] 57 | mergeLists [] xs = xs 58 | mergeLists xs [] = xs 59 | mergeLists (x:xs) (y:ys) 60 | | x < y = x:mergeLists xs (y:ys) 61 | | otherwise = y:mergeLists (x:xs) ys 62 | 63 | main = quickSpec [ 64 | prelude `without` ["*"], 65 | monoType (Proxy :: Proxy OrdA), 66 | monoTypeWithVars ["h", "h1", "h2"] (Proxy :: Proxy (Heap OrdA)), 67 | 68 | "nil" `con` (Nil :: Heap OrdA), 69 | "insert" `con` (insert :: OrdA -> Heap OrdA -> Heap OrdA), 70 | "findMin" `con` (findMin :: Heap OrdA -> OrdA), 71 | "deleteMin" `con` (deleteMin :: Heap OrdA -> Heap OrdA), 72 | "merge" `con` (merge :: Heap OrdA -> Heap OrdA -> Heap OrdA), 73 | "null" `con` (null :: Heap OrdA -> Bool), 74 | "fromList" `con` (fromList :: [OrdA] -> Heap OrdA), 75 | con "True" True, 76 | con "False" False, 77 | 78 | -- A few more list functions that are helpful for getting 79 | -- laws about toList/fromList. 80 | -- We use "background" to mark the functions as background theory, 81 | -- so that we only get laws that involve one of the heap functions. 82 | background [ 83 | "head" `con` (head :: [A] -> A), 84 | "tail" `con` (tail :: [A] -> [A]), 85 | "toList" `con` (toList :: Heap OrdA -> [OrdA]), 86 | "sort" `con` (L.sort :: [OrdA] -> [OrdA]), 87 | "insertList" `con` (L.insert :: OrdA -> [OrdA] -> [OrdA]), 88 | "nullList" `con` (L.null :: [OrdA] -> Bool), 89 | "deleteList" `con` (L.delete :: OrdA -> [OrdA] -> [OrdA]), 90 | "mergeLists" `con` (mergeLists :: [OrdA] -> [OrdA] -> [OrdA])]] 91 | -------------------------------------------------------------------------------- /examples/HugeLists.hs: -------------------------------------------------------------------------------- 1 | -- A stress test using lots and lots of list functions. 2 | {-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RankNTypes, ConstraintKinds, FlexibleContexts #-} 3 | import QuickSpec 4 | import QuickSpec.Internal.Utils 5 | import Data.List 6 | import Control.Monad 7 | 8 | main = quickSpec [ 9 | con "length" (length :: [A] -> Int), 10 | con "sort" (sort :: [Int] -> [Int]), 11 | con "scanr" (scanr :: (A -> B -> B) -> B -> [A] -> [B]), 12 | con "succ" (succ :: Int -> Int), 13 | con ">>=" ((>>=) :: [A] -> (A -> [B]) -> [B]), 14 | con "snd" (snd :: (A, B) -> B), 15 | con "reverse" (reverse :: [A] -> [A]), 16 | con "0" (0 :: Int), 17 | con "," ((,) :: A -> B -> (A, B)), 18 | con ">=>" ((>=>) :: (A -> [B]) -> (B -> [C]) -> A -> [C]), 19 | con ":" ((:) :: A -> [A] -> [A]), 20 | con "break" (break :: (A -> Bool) -> [A] -> ([A], [A])), 21 | con "filter" (filter :: (A -> Bool) -> [A] -> [A]), 22 | con "scanl" (scanl :: (B -> A -> B) -> B -> [A] -> [B]), 23 | con "zipWith" (zipWith :: (A -> B -> C) -> [A] -> [B] -> [C]), 24 | con "concat" (concat :: [[A]] -> [A]), 25 | con "zip" (zip :: [A] -> [B] -> [(A, B)]), 26 | con "usort" (usort :: [Int] -> [Int]), 27 | con "sum" (sum :: [Int] -> Int), 28 | con "++" ((++) :: [A] -> [A] -> [A]), 29 | con "map" (map :: (A -> B) -> [A] -> [B]), 30 | con "foldl" (foldl :: (B -> A -> B) -> B -> [A] -> B), 31 | con "takeWhile" (takeWhile :: (A -> Bool) -> [A] -> [A]), 32 | con "foldr" (foldr :: (A -> B -> B) -> B -> [A] -> B), 33 | con "drop" (drop :: Int -> [A] -> [A]), 34 | con "dropWhile" (dropWhile :: (A -> Bool) -> [A] -> [A]), 35 | con "span" (span :: (A -> Bool) -> [A] -> ([A], [A])), 36 | con "unzip" (unzip :: [(A, B)] -> ([A], [B])), 37 | con "+" ((+) :: Int -> Int -> Int), 38 | con "[]" ([] :: [A]), 39 | con "partition" (partition :: (A -> Bool) -> [A] -> ([A], [A])), 40 | con "fst" (fst :: (A, B) -> A), 41 | con "take" (take :: Int -> [A] -> [A]) ] 42 | -------------------------------------------------------------------------------- /examples/HugeListsMono.hs: -------------------------------------------------------------------------------- 1 | -- A stress test using lots and lots of list functions. 2 | {-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RankNTypes, ConstraintKinds, FlexibleContexts #-} 3 | import QuickSpec 4 | import QuickSpec.Internal.Utils 5 | import Data.List 6 | import Control.Monad 7 | import Test.QuickCheck.Poly 8 | 9 | main = quickSpec [ 10 | con "length" (length :: [OrdA] -> Int), 11 | con "sort" (sort :: [Int] -> [Int]), 12 | con "scanr" (scanr :: (OrdA -> OrdA -> OrdA) -> OrdA -> [OrdA] -> [OrdA]), 13 | con "succ" (succ :: Int -> Int), 14 | con ">>=" ((>>=) :: [OrdA] -> (OrdA -> [OrdA]) -> [OrdA]), 15 | con "snd" (snd :: (OrdA, OrdA) -> OrdA), 16 | con "reverse" (reverse :: [OrdA] -> [OrdA]), 17 | con "0" (0 :: Int), 18 | con "," ((,) :: OrdA -> OrdA -> (OrdA, OrdA)), 19 | con ">=>" ((>=>) :: (OrdA -> [OrdA]) -> (OrdA -> [OrdA]) -> OrdA -> [OrdA]), 20 | con ":" ((:) :: OrdA -> [OrdA] -> [OrdA]), 21 | con "break" (break :: (OrdA -> Bool) -> [OrdA] -> ([OrdA], [OrdA])), 22 | con "filter" (filter :: (OrdA -> Bool) -> [OrdA] -> [OrdA]), 23 | con "scanl" (scanl :: (OrdA -> OrdA -> OrdA) -> OrdA -> [OrdA] -> [OrdA]), 24 | con "zipWith" (zipWith :: (OrdA -> OrdA -> OrdA) -> [OrdA] -> [OrdA] -> [OrdA]), 25 | con "concat" (concat :: [[OrdA]] -> [OrdA]), 26 | con "zip" (zip :: [OrdA] -> [OrdA] -> [(OrdA, OrdA)]), 27 | con "usort" (usort :: [Int] -> [Int]), 28 | con "sum" (sum :: [Int] -> Int), 29 | con "++" ((++) :: [OrdA] -> [OrdA] -> [OrdA]), 30 | con "map" (map :: (OrdA -> OrdA) -> [OrdA] -> [OrdA]), 31 | con "foldl" (foldl :: (OrdA -> OrdA -> OrdA) -> OrdA -> [OrdA] -> OrdA), 32 | con "takeWhile" (takeWhile :: (OrdA -> Bool) -> [OrdA] -> [OrdA]), 33 | con "foldr" (foldr :: (OrdA -> OrdA -> OrdA) -> OrdA -> [OrdA] -> OrdA), 34 | con "drop" (drop :: Int -> [OrdA] -> [OrdA]), 35 | con "dropWhile" (dropWhile :: (OrdA -> Bool) -> [OrdA] -> [OrdA]), 36 | con "span" (span :: (OrdA -> Bool) -> [OrdA] -> ([OrdA], [OrdA])), 37 | con "unzip" (unzip :: [(OrdA, OrdA)] -> ([OrdA], [OrdA])), 38 | con "+" ((+) :: Int -> Int -> Int), 39 | con "[]" ([] :: [OrdA]), 40 | con "partition" (partition :: (OrdA -> Bool) -> [OrdA] -> ([OrdA], [OrdA])), 41 | con "fst" (fst :: (OrdA, OrdA) -> OrdA), 42 | con "take" (take :: Int -> [OrdA] -> [OrdA]) ] 43 | -------------------------------------------------------------------------------- /examples/IntSet.hs: -------------------------------------------------------------------------------- 1 | -- Laws about Data.IntSet. 2 | -- Illustrates user-defined data types. 3 | import QuickSpec 4 | import qualified Data.IntSet as IntSet 5 | import Data.IntSet(IntSet) 6 | 7 | main = quickSpec [ 8 | monoType (Proxy :: Proxy IntSet), 9 | withMaxTests 10000, 10 | 11 | series [sig1, sig2, sig3]] 12 | where 13 | sig1 = [ 14 | con "union" IntSet.union, 15 | con "intersection" IntSet.intersection, 16 | con "empty" IntSet.empty ] 17 | 18 | sig2 = [ 19 | con "insert" IntSet.insert, 20 | con "delete" IntSet.delete ] 21 | 22 | sig3 = [ 23 | con "False" False, 24 | predicate "member" IntSet.member ] 25 | -------------------------------------------------------------------------------- /examples/ListHOF.hs: -------------------------------------------------------------------------------- 1 | import QuickSpec 2 | 3 | sig = 4 | [ con "map" (map :: (A -> B) -> [A] -> [B]) 5 | , con "fold" (foldr :: (A -> B -> B) -> B -> [A] -> B) 6 | , con "." ((.) :: (B -> C) -> (A -> B) -> (A -> C)) 7 | , con "[]" ([] :: [A]) 8 | , con ":" ((:) :: A -> [A] -> [A]) 9 | ] 10 | 11 | main = quickSpec sig 12 | -------------------------------------------------------------------------------- /examples/ListMonad.hs: -------------------------------------------------------------------------------- 1 | -- The monad laws for lists. 2 | import Control.Monad 3 | import QuickSpec 4 | 5 | main = quickSpec [ 6 | withMaxTestSize 20, 7 | con "return" (return :: A -> [A]), 8 | con ">>=" ((>>=) :: [A] -> (A -> [B]) -> [B]), 9 | con "++" ((++) :: [A] -> [A] -> [A]), 10 | con ">=>" ((>=>) :: (A -> [B]) -> (B -> [C]) -> A -> [C]) ] 11 | -------------------------------------------------------------------------------- /examples/Lists.hs: -------------------------------------------------------------------------------- 1 | -- Some usual list functions. 2 | {-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RankNTypes, ConstraintKinds, FlexibleContexts #-} 3 | import QuickSpec 4 | 5 | main = quickSpec [ 6 | con "reverse" (reverse :: [A] -> [A]), 7 | con "++" ((++) :: [A] -> [A] -> [A]), 8 | con "[]" ([] :: [A]), 9 | con "map" (map :: (A -> B) -> [A] -> [B]), 10 | con "length" (length :: [A] -> Int), 11 | con "concat" (concat :: [[A]] -> [A]), 12 | 13 | -- Add some numeric functions to get more laws about length. 14 | arith (Proxy :: Proxy Int) ] 15 | -------------------------------------------------------------------------------- /examples/Map.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, TypeApplications, TypeOperators #-} 2 | import QuickSpec 3 | import qualified Data.Map as Map 4 | import Test.QuickCheck 5 | import Data.Map(Map) 6 | 7 | newtype Key = Key Int deriving (Eq, Ord, Arbitrary) 8 | newtype Value = Value Int deriving (Eq, Ord, Arbitrary) 9 | 10 | main = quickSpec [ 11 | withMaxTermSize 8, 12 | monoTypeWithVars ["k"] (Proxy :: Proxy Key), 13 | monoTypeWithVars ["v"] (Proxy :: Proxy Value), 14 | monoTypeWithVars ["m"] (Proxy :: Proxy (Map Key Value)), 15 | 16 | background [ 17 | predicate "/=" ((/=) :: Key -> Key -> Bool), 18 | con "Nothing" (Nothing :: Maybe A), 19 | con "Just" (Just :: A -> Maybe A)], 20 | 21 | series [sig1, sig2, sig3]] 22 | where 23 | sig1 = [ 24 | con "empty" (Map.empty :: Map Key Value), 25 | con "lookup" (Map.lookup :: Key -> Map Key Value -> Maybe Value)] 26 | sig2 = [ 27 | con "insert" (Map.insert :: Key -> Value -> Map Key Value -> Map Key Value)] 28 | sig3 = [ 29 | con "delete" (Map.delete :: Key -> Map Key Value -> Map Key Value)] 30 | -------------------------------------------------------------------------------- /examples/Music/MusicQS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving #-} 2 | --module MusicQS where 3 | 4 | import Music hiding (main) 5 | import Perform 6 | import Test.QuickCheck 7 | import Data.Ratio 8 | import Control.Monad 9 | import QuickSpec 10 | import QuickSpec.Internal.Utils 11 | import Data.Monoid 12 | import Data.List 13 | import qualified Data.Set as Set 14 | 15 | deriving instance Typeable Positive 16 | 17 | instance Arbitrary IName where 18 | arbitrary = oneof (map return [AcousticGrandPiano .. Percussion]) 19 | shrink = genericShrink 20 | 21 | instance Arbitrary PitchClass where 22 | arbitrary = oneof (map return [Cf .. Bs]) 23 | shrink = genericShrink 24 | 25 | -- Work around bad QuickCheck generator for rationals. 26 | -- To do: fix this in QuickCheck! 27 | genRatio :: Gen Rational 28 | genRatio = do 29 | n <- sized $ \k -> choose (1, k `max` 1) 30 | m <- sized $ \k -> choose (0, n*k `max` 1) 31 | return (fromIntegral m/fromIntegral n) 32 | 33 | instance Arbitrary Music where 34 | shrink = genericShrink 35 | arbitrary = sized arb' 36 | where 37 | arb' 0 = oneof [liftM2 Note arbitrary genRatio, 38 | liftM Rest genRatio] 39 | arb' n = oneof [liftM2 Note arbitrary genRatio, 40 | liftM Rest genRatio, 41 | liftM2 (:+:) submusic2 submusic2, 42 | liftM2 (:=:) submusic2 submusic2, 43 | liftM2 Tempo (genRatio `suchThat` (> 0)) submusic, 44 | liftM2 Trans arbitrary submusic, 45 | liftM2 Instr arbitrary submusic] 46 | where submusic = arb' (n-1) 47 | submusic2 = arb' (n `div` 2) 48 | 49 | instance Arbitrary Context where 50 | shrink = genericShrink 51 | arbitrary = liftM4 Context arbitrary arbitrary (arbitrary `suchThat` (> 0)) arbitrary 52 | 53 | instance Observe Context Performance Music where 54 | observe ctx m = usort (perform ctx (m :+: beep)) 55 | where 56 | beep = Note (C, 4) 1 57 | 58 | newtype NonNeg = NonNeg Rational deriving (Eq, Ord, Show, Num, Fractional) 59 | instance Arbitrary NonNeg where arbitrary = NonNeg <$> genRatio 60 | newtype Pos = Pos Rational deriving (Eq, Ord, Show, Num, Fractional) 61 | instance Arbitrary Pos where arbitrary = Pos <$> (genRatio `suchThat` (> 0)) 62 | 63 | note :: Pitch -> NonNeg -> Music 64 | note p (NonNeg x) = Note p x 65 | 66 | rest :: NonNeg -> Music 67 | rest (NonNeg x) = Rest x 68 | 69 | tempo :: Pos -> Music -> Music 70 | tempo (Pos x) m = Tempo x m 71 | 72 | main = quickSpec [ 73 | monoType (Proxy :: Proxy NonNeg), 74 | monoType (Proxy :: Proxy Pos), 75 | monoTypeWithVars ["p", "q", "r"] (Proxy :: Proxy Pitch), 76 | monoTypeObserveWithVars ["m", "n", "o"] (Proxy :: Proxy Music), 77 | 78 | background bg, 79 | series [sig1, sig2, sig3] ] 80 | where 81 | bg = [ 82 | arith (Proxy :: Proxy NonNeg), 83 | arith (Proxy :: Proxy Pos) `without` ["0"], 84 | con "*" ((*) :: Pos -> Pos -> Pos), 85 | con "/" ((/) :: Pos -> Pos -> Pos), 86 | con "max" (max :: NonNeg -> NonNeg -> NonNeg), 87 | con "" (\(Pos x) -> NonNeg x) ] 88 | 89 | sig1 = [ con "Note" note, 90 | con "Rest" rest, 91 | con ":+:" (:+:) ] 92 | sig2 = [ con ":=:" (:=:) ] 93 | sig3 = [ con "Tempo" tempo ] 94 | -------------------------------------------------------------------------------- /examples/Music/MusicQS1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable #-} 2 | --module MusicQS where 3 | 4 | import Music hiding (main) 5 | import Perform 6 | import Test.QuickCheck 7 | import Data.Ratio 8 | import Control.Monad 9 | import Test.QuickSpec 10 | import Data.Typeable 11 | 12 | deriving instance Typeable Positive 13 | 14 | instance Arbitrary IName where 15 | arbitrary = oneof (map return [AcousticGrandPiano .. Percussion]) 16 | shrink = genericShrink 17 | 18 | instance Arbitrary PitchClass where 19 | arbitrary = oneof (map return [Cf .. Bs]) 20 | shrink = genericShrink 21 | 22 | instance Arbitrary Music where 23 | shrink = genericShrink 24 | arbitrary = sized arb' 25 | where 26 | arb' 0 = oneof [liftM2 note arbitrary arbitrary, 27 | liftM rest arbitrary] 28 | arb' n = oneof [liftM2 note arbitrary arbitrary, 29 | liftM rest arbitrary, 30 | liftM2 (:+:) submusic2 submusic2, 31 | liftM2 (:=:) submusic2 submusic2, 32 | liftM2 tempo arbitrary submusic, 33 | liftM2 Trans arbitrary submusic, 34 | liftM2 Instr arbitrary submusic] 35 | where submusic = arb' (n-1) 36 | submusic2 = arb' (n `div` 2) 37 | 38 | instance Arbitrary Context where 39 | shrink = genericShrink 40 | arbitrary = liftM4 Context arbitrary arbitrary (arbitrary `suchThat` (> 0)) arbitrary 41 | 42 | 43 | note :: (PitchClass, Int) -> Positive Rational -> Music 44 | note n (Positive x) = Note n x 45 | 46 | rest :: Positive Rational -> Music 47 | rest (Positive x) = Rest x 48 | 49 | tempo :: Positive Rational -> Music -> Music 50 | tempo (Positive x) m = Tempo x m 51 | 52 | obsMusic :: Music -> Gen Performance 53 | obsMusic m = liftM2 perform arbitrary (return (m :+: c 1 tn)) 54 | 55 | prop_com :: Context -> Music -> Music -> Property 56 | prop_com c m1 m2 = perform c (m1 :=: m2) === perform c (m2 :=: m1) 57 | 58 | prop_assoc :: Context -> Music -> Music -> Music -> Property 59 | prop_assoc c m1 m2 m3 = perform c ((m1 :+: m2) :+: m3) === perform c (m1 :+: (m2 :+: m3)) 60 | 61 | sig = 62 | signature [ 63 | withDepth 5, 64 | withSize 7, 65 | withTests 100, 66 | observer2 (\ctx x -> perform ctx (x :+: c 1 tn)), 67 | vars ["x", "y", "z"] (undefined :: (PitchClass, Int)), 68 | vars ["x", "y", "z"] (undefined :: IName), 69 | vars ["x", "y", "z"] (undefined :: Music), 70 | vars ["x", "y", "z"] (undefined :: Positive Rational), 71 | vars ["x", "y", "z"] (undefined :: Int), 72 | fun2 "+" (\(Positive x) (Positive y) -> Positive (x+y) :: Positive Rational), 73 | fun2 "max" (\(Positive x) (Positive y) -> Positive (max x y) :: Positive Rational), 74 | fun2 "+'" ((+) :: Int -> Int -> Int), 75 | fun2 "*" (\(Positive x) (Positive y) -> Positive (x*y) :: Positive Rational), 76 | fun0 "1" (Positive 1 :: Positive Rational), 77 | fun1 "recip" (\(Positive x) -> Positive (1/x) :: Positive Rational), 78 | blind2 ":+:" (:+:), 79 | blind2 ":=:" (:=:), 80 | blind2 "tempo" tempo, 81 | blind2 "Trans" Trans, 82 | blind2 "Instr" Instr, 83 | blind2 "note" note, 84 | blind1 "rest" rest, 85 | fun1 "dur" (Positive . dur), 86 | blind2 "cut" (\(Positive x) m -> cut x m), 87 | blind2 "/=:" (/=:) ] 88 | 89 | main = quickSpec sig 90 | -------------------------------------------------------------------------------- /examples/Octonions.hs: -------------------------------------------------------------------------------- 1 | -- The octonions, made using the Cayley-Dickson construction. 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleInstances #-} 3 | import Data.Ratio 4 | import QuickSpec 5 | import Test.QuickCheck 6 | import Twee.Pretty 7 | import Control.Monad 8 | import Data.Proxy 9 | 10 | newtype SmallRational = SmallRational Rational 11 | deriving (Eq, Ord, Num, Typeable, Fractional, Conj, CoArbitrary, Show) 12 | instance Arbitrary SmallRational where 13 | arbitrary = SmallRational <$> liftM2 (%) arbitrary (arbitrary `suchThat` (/= 0)) 14 | 15 | -- A class for types with conjugation, a norm operator and a generator. 16 | class Fractional a => Conj a where 17 | conj :: a -> a 18 | norm :: a -> Rational 19 | it :: Gen a 20 | 21 | instance Conj Rational where 22 | conj x = x 23 | norm x = x*x 24 | -- Only generate small rationals for efficiency. 25 | it = liftM2 (Prelude./) (elements [-10..10]) (elements [1..10]) 26 | 27 | instance Conj a => Conj (a, a) where 28 | conj (x, y) = (conj x, negate y) 29 | norm (x, y) = norm x + norm y 30 | it = liftM2 (,) it it 31 | 32 | instance Conj a => Num (a, a) where 33 | fromInteger n = (fromInteger n, 0) 34 | (x, y) + (z, w) = (x + z, y + w) 35 | (a, b) * (c, d) = (a * c - conj d * b, d * a + b * conj c) 36 | negate (x, y) = (negate x, negate y) 37 | 38 | instance Conj a => Fractional (a, a) where 39 | fromRational x = (fromRational x, 0) 40 | recip x = conj x * fromRational (recip (norm x)) 41 | 42 | newtype Complex = Complex (SmallRational, SmallRational) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show) 43 | newtype Quaternion = Quaternion (Complex, Complex) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show) 44 | newtype Octonion = Octonion (Quaternion, Quaternion) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show) 45 | 46 | newtype It = It Octonion deriving (Eq, Ord, Num, Typeable, Fractional, Conj, CoArbitrary, Show) 47 | 48 | instance Arbitrary It where 49 | -- Division is undefined on zero octonions. 50 | arbitrary = It <$> arbitrary `suchThat` (/= 0) 51 | 52 | main = quickSpec [ 53 | -- Make the pruner more powerful, which is helpful when Doing Maths 54 | withPruningTermSize 9, 55 | -- One test suffices :) 56 | withMaxTests 1, 57 | con "*" ((*) :: It -> It -> It), 58 | (con "inv" (recip :: It -> It)), 59 | con "1" (1 :: It), 60 | monoType (Proxy :: Proxy It)] 61 | -------------------------------------------------------------------------------- /examples/OctonionsGroupy.hs: -------------------------------------------------------------------------------- 1 | -- The octonions, made using the Cayley-Dickson construction. 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-} 3 | import Data.Ratio 4 | import QuickSpec 5 | import Test.QuickCheck 6 | import Twee.Pretty 7 | import Control.Monad 8 | import Data.Proxy 9 | 10 | newtype SmallRational = SmallRational Rational 11 | deriving (Eq, Ord, Num, Typeable, Fractional, Conj, CoArbitrary, Show) 12 | instance Arbitrary SmallRational where 13 | arbitrary = SmallRational <$> liftM2 (%) arbitrary (arbitrary `suchThat` (/= 0)) 14 | 15 | -- A class for types with conjugation, a norm operator and a generator. 16 | class Fractional a => Conj a where 17 | conj :: a -> a 18 | norm :: a -> Rational 19 | it :: Gen a 20 | 21 | instance Conj Rational where 22 | conj x = x 23 | norm x = x*x 24 | -- Only generate small rationals for efficiency. 25 | it = liftM2 (Prelude./) (elements [-10..10]) (elements [1..10]) 26 | 27 | instance Conj a => Conj (a, a) where 28 | conj (x, y) = (conj x, negate y) 29 | norm (x, y) = norm x + norm y 30 | it = liftM2 (,) it it 31 | 32 | instance Conj a => Num (a, a) where 33 | fromInteger n = (fromInteger n, 0) 34 | (x, y) + (z, w) = (x + z, y + w) 35 | (a, b) * (c, d) = (a * c - conj d * b, d * a + b * conj c) 36 | negate (x, y) = (negate x, negate y) 37 | 38 | instance Conj a => Fractional (a, a) where 39 | fromRational x = (fromRational x, 0) 40 | recip x = conj x * fromRational (recip (norm x)) 41 | 42 | newtype Complex = Complex (SmallRational, SmallRational) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show) 43 | newtype Quaternion = Quaternion (Complex, Complex) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show) 44 | newtype Octonion = Octonion (Quaternion, Quaternion) deriving (Eq, Ord, Num, Typeable, Fractional, Conj, Arbitrary, CoArbitrary, Show) 45 | 46 | newtype It = It Octonion deriving (Eq, Ord, Num, Typeable, Fractional, Conj, CoArbitrary, Show) 47 | 48 | instance Arbitrary It where 49 | -- Division is undefined on zero octonions. 50 | arbitrary = It <$> resize 1 (arbitrary `suchThat` (/= 0)) 51 | 52 | data Op = L It | R It | Inverse | Compose [Op] 53 | 54 | instance Arbitrary Op where 55 | arbitrary = 56 | fmap (Compose . take 5) $ listOf $ oneof 57 | [L <$> arbitrary, 58 | R <$> arbitrary, 59 | return Inverse] 60 | 61 | eval :: Op -> It -> It 62 | eval (L x) y = x * y 63 | eval (R y) x = x * y 64 | eval Inverse x = recip x 65 | eval (Compose ops) x = foldr (.) id (map eval ops) x 66 | 67 | invert :: Op -> Op 68 | invert (L x) = L (recip x) 69 | invert (R x) = R (recip x) 70 | invert Inverse = Inverse 71 | invert (Compose ops) = Compose (map invert (reverse ops)) 72 | 73 | instance Observe It It Op where 74 | observe x op = eval op x 75 | 76 | main = quickSpec [ 77 | -- Make the pruner more powerful, which is helpful when Doing Maths 78 | --withPruningTermSize 9, 79 | withMaxTermSize 11, 80 | monoType (Proxy :: Proxy It), 81 | monoTypeObserve (Proxy :: Proxy Op), 82 | -- One test suffices :) 83 | withMaxTests 100, 84 | series [ 85 | [con "*" ((*) :: It -> It -> It), 86 | con "inv" (recip :: It -> It), 87 | con "1" (1 :: It)], 88 | [con "l" L, 89 | con "r" R, 90 | con "j" Inverse, 91 | con "jconj" (\f -> Compose [Inverse, f, Inverse]), 92 | con "t" (\x -> Compose $ reverse [R x, invert (L x)]), 93 | con "l2" (\x y -> Compose [L x, L y, invert (L (y * x))]), 94 | con "r2" (\x y -> Compose $ reverse [R x, R y, invert (R (x * y))]), 95 | con "c" (\x y -> Compose [R x, L y, R (recip x), L (recip y)]), 96 | con "inverted" invert, 97 | con "id" (Compose []), 98 | con "." (\f g -> Compose [f, g])], 99 | --con "inv" (recip :: It -> It), 100 | --con "1" (1 :: It)], 101 | [{-con "@" eval-} ]]] 102 | -------------------------------------------------------------------------------- /examples/Parsec.hs: -------------------------------------------------------------------------------- 1 | -- Parser combinators. 2 | -- Illustrates observational equality with polymorphic types. 3 | {-# LANGUAGE DeriveDataTypeable, TypeOperators, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 4 | import Control.Monad 5 | import Test.QuickCheck 6 | import QuickSpec 7 | import QuickSpec.Internal 8 | import Data.List 9 | import Text.Parsec.Char 10 | import Text.Parsec.String 11 | import Text.Parsec.Prim 12 | import Text.Parsec.Pos 13 | import Text.Parsec.Error 14 | import Data.Constraint 15 | import Data.Functor.Identity 16 | import Data.Ord 17 | 18 | deriving instance Eq a => Eq (Consumed a) 19 | deriving instance Ord a => Ord (Consumed a) 20 | instance (Eq a, Eq b, Eq c) => Eq (Reply a b c) where 21 | x == y = toMaybe x == toMaybe y 22 | instance (Ord a, Ord b, Ord c) => Ord (Reply a b c) where 23 | compare = comparing toMaybe 24 | deriving instance (Eq a, Eq b) => Eq (State a b) 25 | deriving instance (Ord a, Ord b) => Ord (State a b) 26 | 27 | toMaybe (Ok x s _) = Just (x, s) 28 | toMaybe (Error _) = Nothing 29 | 30 | instance Arbitrary SourcePos where 31 | arbitrary = liftM3 newPos arbitrary arbitrary arbitrary 32 | 33 | arbString :: Gen String 34 | arbString = listOf (choose ('a', 'b')) 35 | 36 | -- Generate random parsers. 37 | instance Arbitrary (Parser String) where 38 | arbitrary = sized arb 39 | where 40 | arb :: Int -> Gen (Parser String) 41 | arb n = 42 | oneof $ 43 | [ return <$> arbString ] ++ 44 | [ liftM2 (>>) arb2 arb2 | n > 0 ] ++ 45 | [ liftM2 (>>=) arb2 (resize (n `div` 2) arbitrary) | n > 0 ] ++ 46 | [ string <$> arbString ] ++ 47 | [ try <$> arb (n-1) | n > 0 ] ++ 48 | [ liftM2 mplus arb2 arb2 | n > 0 ] 49 | where 50 | arb2 = arb (n `div` 2) 51 | 52 | instance Arbitrary (State String ()) where 53 | arbitrary = liftM3 State arbString arbitrary arbitrary 54 | 55 | -- Observational equality for parsers. 56 | instance Ord a => Observe (State String ()) (Identity (Consumed (Identity (Reply String () a)))) (Parser a) where 57 | observe state parser = runParsecT parser state 58 | 59 | main = quickSpec [ 60 | inst (Sub Dict :: () :- Arbitrary (Parser String)), 61 | inst (Sub Dict :: Ord A :- Observe (State String ()) (Identity (Consumed (Identity (Reply String () A)))) (Parser A)), 62 | inst (Sub Dict :: () :- Arbitrary (State String ())), 63 | instFun (arbString :: Gen String), 64 | defaultTo (Proxy :: Proxy String), 65 | withMaxTermSize 7, 66 | withMaxTestSize 5, 67 | withMaxTests 10000, 68 | 69 | -- background [ 70 | --con "return" (return :: A -> Parser A), 71 | -- con "()" (), 72 | -- con "void" (void :: Parser A -> Parser ()), 73 | con ">>" ((>>) :: Parser A -> Parser B -> Parser B), 74 | con "<<|>" (\p q -> try p <|> q :: Parser A), 75 | --con "<|>" ((<|>) :: Parser A -> Parser A -> Parser A)], 76 | 77 | -- con "string" (string :: String -> Parser String), 78 | con "try" (try :: Parser A -> Parser A)] 79 | 80 | -------------------------------------------------------------------------------- /examples/Parsing.hs: -------------------------------------------------------------------------------- 1 | -- Parser combinators. 2 | -- Illustrates observational equality with polymorphic types. 3 | {-# LANGUAGE DeriveDataTypeable, TypeOperators, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 4 | import Control.Monad 5 | import Test.QuickCheck 6 | import QuickSpec 7 | import Data.List 8 | import Text.ParserCombinators.ReadP 9 | import Data.Constraint 10 | 11 | deriving instance Typeable ReadP 12 | 13 | -- Generate random parsers. 14 | instance Arbitrary a => Arbitrary (ReadP a) where 15 | arbitrary = fmap readS_to_P arbReadS 16 | 17 | arbReadS :: Arbitrary a => Gen (String -> [(a, String)]) 18 | arbReadS = fmap convert (liftM2 (,) (elements [0..5]) arbitrary) 19 | where 20 | convert (n, parse) xs = take n [(x, drop n xs) | (x, n) <- parse xs] 21 | 22 | -- Observational equality for parsers. 23 | instance Ord a => Observe String [(a, String)] (ReadP a) where 24 | observe input parser = sort (readP_to_S parser input) 25 | 26 | peek :: ReadP Char 27 | peek = do 28 | (x:_) <- look 29 | return x 30 | 31 | main = quickSpec [ 32 | inst (Sub Dict :: Arbitrary A :- Arbitrary (ReadP A)), 33 | inst (Sub Dict :: Ord A :- Observe String [(A, String)] (ReadP A)), 34 | 35 | background [ 36 | con "return" (return :: A -> ReadP A), 37 | con "()" (), 38 | con "void" (void :: ReadP A -> ReadP ()), 39 | con ">>=" ((>>=) :: ReadP A -> (A -> ReadP B) -> ReadP B), 40 | con ">=>" ((>=>) :: (A -> ReadP B) -> (B -> ReadP C) -> A -> ReadP C) ], 41 | 42 | con "get" get, 43 | con "peek" peek, 44 | con "+++" ((+++) :: ReadP A -> ReadP A -> ReadP A), 45 | con "<++" ((<++) :: ReadP A -> ReadP A -> ReadP A), 46 | con "pfail" (pfail :: ReadP A), 47 | con "eof" eof ] 48 | 49 | -------------------------------------------------------------------------------- /examples/PrettyPrinting.hs: -------------------------------------------------------------------------------- 1 | -- Pretty-printing combinators. 2 | -- Illustrates observational equality and using custom generators. 3 | -- See the QuickSpec paper for more details. 4 | {-# LANGUAGE DeriveDataTypeable, TypeOperators, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 5 | import Prelude hiding ((<>)) 6 | import Control.Monad 7 | import Test.QuickCheck 8 | import QuickSpec 9 | import Text.PrettyPrint.HughesPJ hiding (Str) 10 | import Data.Proxy 11 | import Data.Constraint 12 | 13 | deriving instance Typeable Doc 14 | 15 | instance Arbitrary Doc where 16 | arbitrary = 17 | sized $ \n -> 18 | let bin = resize (n `div` 2) arbitrary 19 | un = resize (n-1) arbitrary in 20 | oneof $ 21 | [ liftM2 ($$) bin bin | n > 0 ] ++ 22 | [ liftM2 (<>) bin bin | n > 0 ] ++ 23 | [ liftM2 nest arbitrary un | n > 0 ] ++ 24 | [ fmap text arbitrary ] 25 | 26 | -- Observational equality. 27 | instance Observe Context Str Doc where 28 | observe (Context ctx) d = Str (render (ctx d)) 29 | newtype Str = Str String deriving (Eq, Ord) 30 | 31 | newtype Context = Context (Doc -> Doc) 32 | 33 | instance Arbitrary Context where 34 | arbitrary = Context <$> ctx 35 | where 36 | ctx = 37 | sized $ \n -> 38 | oneof $ 39 | [ return id ] ++ 40 | [ liftM2 (\x y d -> op (x d) y) (resize (n `div` 2) ctx) (resize (n `div` 2) arbitrary) | n > 0, op <- [(<>), ($$)] ] ++ 41 | [ liftM2 (\x y d -> op x (y d)) (resize (n `div` 2) arbitrary) (resize (n `div` 2) ctx) | n > 0, op <- [(<>), ($$)] ] ++ 42 | [ liftM2 (\x y d -> nest x (y d)) arbitrary (resize (n-1) ctx) | n > 0 ] 43 | 44 | unindented :: Doc -> Bool 45 | unindented d = render (nest 100 (text "" <> d)) == render (nest 100 d) 46 | 47 | nesting :: Doc -> Int 48 | nesting d = head [ i | i <- nums, unindented (nest (-i) d) ] 49 | where 50 | nums = 0:concat [ [i, -i] | i <- [1..] ] 51 | 52 | main = quickSpec [ 53 | withMaxTermSize 9, 54 | 55 | background [ 56 | con "[]" ([] :: [A]), 57 | con "++" ((++) :: [A] -> [A] -> [A]), 58 | con "0" (0 :: Int), 59 | con "+" ((+) :: Int -> Int -> Int), 60 | con "length" (length :: [A] -> Int) ], 61 | 62 | 63 | con "text" text, 64 | con "nest" nest, 65 | --con "nesting" nesting, 66 | con "<>" (<>), 67 | con "$$" ($$), 68 | 69 | monoTypeObserve (Proxy :: Proxy Doc), 70 | defaultTo (Proxy :: Proxy Bool)] 71 | -------------------------------------------------------------------------------- /examples/PrettyPrintingModel.hs: -------------------------------------------------------------------------------- 1 | -- Pretty-printing combinators, testing against a model implementation. 2 | -- Illustrates running QuickSpec on a progressively larger set of signatures. 3 | -- See the QuickSpec paper for more details. 4 | {-# LANGUAGE DeriveDataTypeable, TypeOperators #-} 5 | import Prelude hiding ((<>)) 6 | import Control.Monad 7 | import Test.QuickCheck 8 | import QuickSpec 9 | import Data.Proxy 10 | 11 | newtype Layout = Layout [(Int, String)] 12 | deriving (Typeable, Eq, Ord, Show) 13 | 14 | instance Arbitrary Layout where 15 | arbitrary = fmap Layout (liftM2 (:) arbitrary arbitrary) 16 | 17 | text :: String -> Layout 18 | text s = Layout [(0, s)] 19 | 20 | nest :: Int -> Layout -> Layout 21 | nest k (Layout l) = Layout [(i+k, s) | (i, s) <- l] 22 | 23 | ($$) :: Layout -> Layout -> Layout 24 | Layout xs $$ Layout ys = Layout (xs ++ ys) 25 | 26 | (<>) :: Layout -> Layout -> Layout 27 | Layout xs <> Layout ys = 28 | combine (init xs) (last xs) (head ys) (tail ys) 29 | where 30 | combine xs (i, s) (j, t) ys = 31 | Layout xs $$ 32 | Layout [(i, s ++ t)] $$ 33 | nest (i + length s - j) (Layout ys) 34 | 35 | nesting :: Layout -> Int 36 | nesting (Layout ((i,_):_)) = i 37 | 38 | main = quickSpec [ 39 | withMaxTermSize 9, 40 | monoType (Proxy :: Proxy Layout), 41 | background [ 42 | con "\"\"" "", 43 | con "++" ((++) :: String -> String -> String), 44 | con "0" (0 :: Int), 45 | con "+" ((+) :: Int -> Int -> Int), 46 | con "length" (length :: String -> Int) ], 47 | series [sig1, sig2]] 48 | where 49 | sig1 = [ 50 | con "text" text, 51 | con "nest" nest, 52 | con "$$" ($$), 53 | con "<>" (<>) ] 54 | sig2 = [con "nesting" nesting] 55 | -------------------------------------------------------------------------------- /examples/PrettyPrintingWadler.hs: -------------------------------------------------------------------------------- 1 | -- Pretty-printing combinators. 2 | -- Illustrates observational equality and using custom generators. 3 | -- See the QuickSpec paper for more details. 4 | {-# LANGUAGE DeriveDataTypeable, TypeOperators, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 5 | import Prelude hiding ((<>), (<$>)) 6 | import Control.Monad 7 | import Test.QuickCheck 8 | import QuickSpec 9 | import QuickSpec.Internal(instFun) 10 | import Text.PrettyPrint.ANSI.Leijen hiding (Str) 11 | import Data.Proxy 12 | import Data.Constraint 13 | 14 | deriving instance Typeable Doc 15 | 16 | instance Arbitrary Doc where 17 | arbitrary = 18 | sized $ \n -> 19 | let bin = resize (n `div` 2) arbitrary 20 | un = resize (n-1) arbitrary 21 | op = elements [(<>), (<$>), (), (<$$>), (), (<+>)] in 22 | oneof $ 23 | [ liftM3 id op bin bin | n > 0 ] ++ 24 | [ liftM2 nest arbitrary un | n > 0 ] ++ 25 | [ elements [line, linebreak, softline, softbreak, hardline ]] ++ 26 | [ fmap group un | n > 0 ] ++ 27 | [ fmap text (fmap (filter (/= '\n')) arbitrary) ] 28 | 29 | -- Observational equality. 30 | instance Observe (Context, Float, Int) String Doc where 31 | observe (Context ctx, f, n) d = 32 | displayS (renderPretty f n (ctx d)) "" 33 | 34 | newtype Context = Context (Doc -> Doc) 35 | 36 | instance Arbitrary Context where 37 | arbitrary = fmap Context ctx 38 | where 39 | ctx = 40 | sized $ \n -> 41 | oneof $ 42 | [ return id ] ++ 43 | [ liftM2 (\x y d -> op (x d) y) (resize (n `div` 2) ctx) (resize (n `div` 2) arbitrary) | n > 0, op <- [(<>), (<+>), (<$>), (), (<$$>), ()] ] ++ 44 | [ liftM2 (\x y d -> op x (y d)) (resize (n `div` 2) arbitrary) (resize (n `div` 2) ctx) | n > 0, op <- [(<>), (<+>), (<$>), (), (<$$>), ()] ] ++ 45 | [ fmap (group .) (resize (n-1) ctx) | n > 0 ] ++ 46 | [ liftM2 (\x y d -> nest x (y d)) (fmap abs arbitrary) (resize (n-1) ctx) | n > 0 ] 47 | 48 | --unindented :: Doc -> Bool 49 | --unindented d = render (nest 100 (text "" <> d)) == render (nest 100 d) 50 | -- 51 | --nesting :: Doc -> Int 52 | --nesting d = head [ i | i <- nums, unindented (nest (-i) d) ] 53 | -- where 54 | -- nums = 0:concat [ [i, -i] | i <- [1..] ] 55 | 56 | main = quickSpec [ 57 | withMaxTermSize 9, 58 | 59 | background [ 60 | con "[]" ([] :: [A]), 61 | con "++" ((++) :: [A] -> [A] -> [A]), 62 | con "0" (0 :: Int), 63 | con "+" ((+) :: Int -> Int -> Int), 64 | con "length" (length :: [A] -> Int) ], 65 | 66 | series [ 67 | [con "text" text, 68 | con "nest" nest, 69 | --con "nesting" nesting, 70 | con "<>" ((<>) :: Doc -> Doc -> Doc), 71 | con "<$>" (<$>), 72 | con "" (), 73 | -- con "<$$>" (<$$>), 74 | -- con "" (), 75 | con "<+>" (<+>)], 76 | [con "group" group], 77 | [con "line" line, 78 | -- con "linebreak" linebreak, 79 | -- con "softline" softline, 80 | -- con "softbreak" softbreak, 81 | con "hardline" hardline]], 82 | 83 | instFun (fmap (filter (/= '\n')) arbitrary :: Gen String), 84 | instFun (fmap abs arbitrary :: Gen Int), 85 | instFun (choose (0, 1) :: Gen Double), 86 | 87 | monoTypeObserve (Proxy :: Proxy Doc), 88 | defaultTo (Proxy :: Proxy Bool)] 89 | -------------------------------------------------------------------------------- /examples/Queues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, TypeApplications #-} 2 | 3 | import QuickSpec 4 | import Test.QuickCheck 5 | import Prelude hiding (fst) 6 | 7 | newtype Queue a = Queue [a] deriving (Eq, Ord, Arbitrary, CoArbitrary) 8 | nil = Queue [] 9 | enq x (Queue ys) = Queue (ys ++ [x]) 10 | deq (Queue (x:xs)) = Queue xs 11 | fst (Queue (x:xs)) = x 12 | 13 | main = quickSpec [ 14 | background [ 15 | con "." ((.) @(Queue A) @(Queue A) @(Queue A)), 16 | con "id" (id @(Queue A)) ], 17 | 18 | inst (Sub Dict :: Ord A :- Ord (Queue A)), 19 | inst (Sub Dict :: Arbitrary A :- Arbitrary (Queue A)), 20 | inst (Sub Dict :: CoArbitrary A :- CoArbitrary (Queue A)), 21 | "enq" `con` (enq :: A -> Queue A -> Queue A), 22 | "deq" `con` (deq :: Queue A -> Queue A), 23 | "fst" `con` (fst :: Queue A -> A), 24 | "nil" `con` (nil :: Queue A) 25 | ] 26 | -------------------------------------------------------------------------------- /examples/Regex.hs: -------------------------------------------------------------------------------- 1 | -- Regular expressions. 2 | {-# LANGUAGE GeneralizedNewtypeDeriving,DeriveDataTypeable, FlexibleInstances #-} 3 | import qualified Control.Monad.State as S 4 | import Control.Monad.State hiding (State, state) 5 | import qualified Data.Map as M 6 | import Data.List 7 | import Data.Map(Map) 8 | import Data.Typeable 9 | import QuickSpec 10 | import Test.QuickCheck 11 | import Test.QuickCheck.Random 12 | import Test.QuickCheck.Gen 13 | import Data.Ord 14 | import Data.Monoid 15 | 16 | data Sym = A | B deriving (Eq, Ord, Typeable) 17 | 18 | instance Arbitrary Sym where 19 | arbitrary = elements [A, B] 20 | 21 | newtype State = State Int deriving (Eq, Ord, Num, Show) 22 | 23 | data NFA a = NFA { 24 | epsilons :: Map State [State], 25 | transitions :: Map (State, Maybe a) [State], 26 | initial :: State, 27 | final :: State } deriving Show 28 | 29 | data Regex a = Char a | AnyChar | Epsilon | Zero 30 | | Concat (Regex a) (Regex a) 31 | | Choice (Regex a) (Regex a) 32 | | Plus (Regex a) deriving (Typeable, Show) 33 | 34 | -- This should really use observational equality instead. 35 | vals :: [[Sym]] 36 | vals = unGen (vector 100) (mkQCGen 12345) 10 37 | 38 | instance Eq (Regex Sym) where x == y = x `compare` y == EQ 39 | instance Ord (Regex Sym) where 40 | compare = comparing (\r -> map (run (compile r)) vals) 41 | 42 | instance Arbitrary (Regex Sym) where 43 | arbitrary = sized arb 44 | where arb 0 = oneof [fmap Char arbitrary, return AnyChar, return Epsilon, return Zero] 45 | arb n = oneof [fmap Char arbitrary, return AnyChar, return Epsilon, return Zero, 46 | liftM2 Concat arb' arb', liftM2 Choice arb' arb', fmap Plus (arb (n-1))] 47 | where arb' = arb (n `div` 2) 48 | 49 | star r = Choice Epsilon (Plus r) 50 | 51 | type M a = S.State ([(State, Maybe a, State)], [(State, State)], State) 52 | 53 | edge :: State -> Maybe a -> State -> M a () 54 | edge start e end = modify (\(edges, epsilons, next) -> ((start, e, end):edges, epsilons, next)) 55 | 56 | epsilon :: State -> State -> M a () 57 | epsilon start end = modify (\(edges, epsilons, next) -> (edges, (start, end):epsilons, next)) 58 | 59 | state :: M a State 60 | state = do 61 | (edges, epsilons, next) <- get 62 | put (edges, epsilons, next+1) 63 | return next 64 | 65 | compile1 :: Regex a -> State -> State -> M a () 66 | compile1 (Char c) start end = edge start (Just c) end 67 | compile1 AnyChar start end = edge start Nothing end 68 | compile1 Zero start end = return () 69 | compile1 Epsilon start end = epsilon start end 70 | compile1 (Concat r s) start end = do 71 | mid <- state 72 | compile1 r start mid 73 | compile1 s mid end 74 | compile1 (Choice r s) start end = do 75 | compile1 r start end 76 | compile1 s start end 77 | compile1 (Plus r) start end = do 78 | start' <- state 79 | end' <- state 80 | epsilon start start' 81 | epsilon end' end 82 | epsilon end' start' 83 | compile1 r start' end' 84 | 85 | compile :: Ord a => Regex a -> NFA a 86 | compile r = NFA (close (foldr enter M.empty epsilons)) (foldr flatten M.empty edges) (State 0) (State 1) 87 | where (edges, epsilons, _) = execState (compile1 r (State 0) (State 1)) ([], [], State 2) 88 | flatten (start, edge, to) edges = M.insertWith (++) (start, edge) [to] edges 89 | enter (from, to) epsilons = M.insertWith (++) from [to] epsilons 90 | 91 | close :: Ord a => Map a [a] -> Map a [a] 92 | close m | xs == [] = m 93 | | otherwise = close (foldr enter m xs) 94 | where enter (from, to) epsilons = M.insertWith (++) from [to] epsilons 95 | xs = nub' (close1 m) 96 | 97 | close1 m = do 98 | (from, tos) <- M.toList m 99 | to <- tos 100 | to' <- M.findWithDefault [] to m 101 | guard (to' `notElem` tos && to' /= to && to' /= from) 102 | return (from, to') 103 | 104 | run :: Ord a => NFA a -> [a] -> Bool 105 | run nfa = runFrom nfa [initial nfa] 106 | runFrom nfa states = runFrom' nfa (nub' (concatMap (epsilonClosed nfa) states)) 107 | runFrom' nfa states [] = final nfa `elem` states 108 | 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 109 | epsilonClosed nfa s = s:M.findWithDefault [] s (epsilons nfa) 110 | 111 | nub' :: Ord a => [a] -> [a] 112 | nub' = map head . group . sort 113 | 114 | main = quickSpec [ 115 | con "char" (Char :: Sym -> Regex Sym), 116 | con "any" (AnyChar :: Regex Sym), 117 | con "e" (Epsilon :: Regex Sym), 118 | con "0" (Zero :: Regex Sym), 119 | con ";" (Concat :: Regex Sym -> Regex Sym -> Regex Sym), 120 | con "|" (Choice :: Regex Sym -> Regex Sym -> Regex Sym), 121 | con "*" (star :: Regex Sym -> Regex Sym), 122 | monoType (Proxy :: Proxy (Regex Sym)), 123 | monoType (Proxy :: Proxy Sym) ] 124 | -------------------------------------------------------------------------------- /examples/Regex2.hs: -------------------------------------------------------------------------------- 1 | -- Regular expressions. 2 | {-# LANGUAGE GeneralizedNewtypeDeriving,DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-} 3 | import qualified Control.Monad.State as S 4 | import Control.Monad.State hiding (State, state) 5 | import qualified Data.Map as M 6 | import Data.List 7 | import Data.Map(Map) 8 | import Data.Typeable 9 | import QuickSpec 10 | import Test.QuickCheck 11 | import Test.QuickCheck.Random 12 | import Test.QuickCheck.Gen 13 | import Data.Ord 14 | import Data.Monoid 15 | import Data.Set(Set) 16 | import qualified Data.Set as Set 17 | import Debug.Trace 18 | 19 | data Sym = A | B deriving (Eq, Ord, Typeable, Show) 20 | 21 | instance Arbitrary Sym where 22 | arbitrary = elements [A, B] 23 | 24 | newtype State = State Int deriving (Eq, Ord, Num, Show) 25 | 26 | data Regex a = Char a | AnyChar | Epsilon | Zero 27 | | Concat (Regex a) (Regex a) 28 | | Choice (Regex a) (Regex a) 29 | | Deriv a (Regex a) 30 | | Plus (Regex a) deriving (Typeable, Show) 31 | 32 | instance Observe [Sym] Bool (Regex Sym) where 33 | observe inp r = accepts r inp 34 | 35 | instance Arbitrary (Regex Sym) where 36 | arbitrary = sized arb 37 | where arb 0 = oneof [fmap Char arbitrary, return AnyChar, return Epsilon, return Zero] 38 | arb n = oneof [fmap Char arbitrary, return AnyChar, return Epsilon, return Zero, 39 | liftM2 Concat arb' arb', liftM2 Choice arb' arb', fmap Plus (arb (n-1))] 40 | where arb' = arb (n `div` 2) 41 | 42 | star r = Choice Epsilon (Plus r) 43 | 44 | nub' :: Ord a => [a] -> [a] 45 | nub' = map head . group . sort 46 | 47 | charLike :: Maybe a -> Regex a 48 | charLike Nothing = AnyChar 49 | charLike (Just c) = Char c 50 | 51 | consume :: (Show a, Ord a) => Regex a -> [a] -> Set [a] 52 | consume (Char x) (y:ys) | x == y = Set.singleton ys 53 | consume AnyChar (_:ys) = Set.singleton ys 54 | consume Epsilon ys = Set.singleton ys 55 | consume (Concat r1 r2) xs = 56 | consume r1 xs `bind` consume r2 57 | consume (Choice r1 r2) xs = 58 | consume r1 xs `Set.union` consume r2 xs 59 | consume (Plus r) xs = 60 | consume r xs `Set.union` 61 | (consume r xs `bind` \ys -> 62 | if length xs <= length ys then Set.empty else 63 | Set.singleton ys `Set.union` consume (Plus r) ys) 64 | consume (Deriv x r) xs = 65 | --traceShow (x, r, xs) $ 66 | Set.fromList [ ys | ys <- Set.toList (consume r (x:xs)), length ys <= length xs ] 67 | consume _ _ = Set.empty 68 | 69 | bind :: (Ord a, Ord b) => Set a -> (a -> Set b) -> Set b 70 | s `bind` f = Set.unions (map f (Set.toList s)) 71 | 72 | accepts :: (Show a, Ord a) => Regex a -> [a] -> Bool 73 | accepts r xs = 74 | --traceShow (r, xs) $ 75 | [] `Set.member` consume r xs 76 | 77 | main = quickSpec [ 78 | series [ 79 | [con "char" (Char :: Sym -> Regex Sym), 80 | con "e" (Epsilon :: Regex Sym), 81 | con "0" (Zero :: Regex Sym), 82 | con ";" (Concat :: Regex Sym -> Regex Sym -> Regex Sym), 83 | con "|" (Choice :: Regex Sym -> Regex Sym -> Regex Sym), 84 | con "*" (star :: Regex Sym -> Regex Sym), 85 | con "Nothing" (Nothing :: Maybe Sym), 86 | predicate "/=" ((/=) :: Sym -> Sym -> Bool), 87 | con "Just" (Just :: Sym -> Maybe Sym)], 88 | [con "&&" (&&), 89 | con "||" (||), 90 | con "True" True, 91 | con "[]" ([] :: [Sym]), 92 | con "++" ((++) :: [Sym] -> [Sym] -> [Sym]), 93 | con "False" False], 94 | [con "accepts" (accepts :: Regex Sym -> [Sym] -> Bool)], 95 | [con "deriv" (Deriv :: Sym -> Regex Sym -> Regex Sym)]], 96 | withMaxTestSize 10, 97 | withMaxTests 10000, 98 | monoTypeObserve (Proxy :: Proxy (Regex Sym)), 99 | monoType (Proxy :: Proxy (Maybe Sym)), 100 | monoType (Proxy :: Proxy Sym) ] 101 | -------------------------------------------------------------------------------- /examples/Sorted.hs: -------------------------------------------------------------------------------- 1 | -- Sorting and sorted lists. 2 | -- Illustrates testing of conditional laws. 3 | import QuickSpec 4 | import Data.List 5 | 6 | sorted :: Ord a => [a] -> Bool 7 | sorted [] = True 8 | sorted [_] = True 9 | sorted (x:y:xs) = x <= y && sorted (y:xs) 10 | 11 | main = quickSpec [ 12 | lists `without` ["++"], 13 | con "sort" (sort :: [Int] -> [Int]), 14 | con "insert" (insert :: Int -> [Int] -> [Int]), 15 | predicate "sorted" (sorted :: [Int] -> Bool) ] 16 | -------------------------------------------------------------------------------- /examples/Zip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | -- A test for conditions. 3 | -- Many laws for zip only hold when the arguments have the same 4 | -- length. 5 | import QuickSpec 6 | 7 | eqLen :: [a] -> [b] -> Bool 8 | eqLen xs ys = length xs == length ys 9 | 10 | main = quickSpec [ 11 | -- Explore bigger terms. 12 | withMaxTermSize 8, 13 | con "++" ((++) @Int), 14 | con "zip" (zip @Int @Int), 15 | predicate "eqLen" (eqLen @Int @Int) ] 16 | -------------------------------------------------------------------------------- /examples/tests/AC.hs: -------------------------------------------------------------------------------- 1 | -- a function which satisfies x+(y+z)=y+(x+z) but is not AC 2 | import QuickSpec 3 | import Test.QuickCheck 4 | 5 | data X = A | B | C deriving (Eq, Ord, Enum, Bounded) 6 | instance Arbitrary X where arbitrary = elements [minBound..maxBound] 7 | 8 | funny :: (X, X) -> X 9 | funny(A,A) = C 10 | funny(A,B) = A 11 | funny(A,C) = B 12 | funny(B,A) = C 13 | funny(B,B) = A 14 | funny(B,C) = B 15 | funny(C,A) = B 16 | funny(C,B) = C 17 | funny(C,C) = A 18 | 19 | main = quickSpec [monoType (Proxy :: Proxy X), con "+" (curry funny)] 20 | -------------------------------------------------------------------------------- /examples/tests/AC.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (+) :: X -> X -> X 3 | 4 | == Laws == 5 | 1. x + (y + z) = y + (x + z) 6 | 2. x + (x + (x + y)) = y 7 | 3. (x + x) + (y + y) = (y + y) + (x + x) 8 | 9 | -------------------------------------------------------------------------------- /examples/tests/Arith.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: Int 3 | 1 :: Int 4 | (+) :: Int -> Int -> Int 5 | (*) :: Int -> Int -> Int 6 | 7 | == Laws == 8 | 1. x * y = y * x 9 | 2. x + y = y + x 10 | 3. x * 0 = 0 11 | 4. x * 1 = x 12 | 5. x + 0 = x 13 | 6. (x * y) * z = x * (y * z) 14 | 7. x * (y + y) = y * (x + x) 15 | 8. (x + y) + z = x + (y + z) 16 | 9. x * (y + 1) = x + (x * y) 17 | 10. (x * y) + (x * z) = x * (y + z) 18 | 19 | -------------------------------------------------------------------------------- /examples/tests/ArithBackground.hs: -------------------------------------------------------------------------------- 1 | -- Testing background theories. 2 | import QuickSpec 3 | 4 | main = quickSpec [ 5 | con "0" (0 :: Int), 6 | con "1" (1 :: Int), 7 | con "+" ((+) :: Int -> Int -> Int), 8 | con "*" ((*) :: Int -> Int -> Int), 9 | 10 | withBackgroundStrings ["*(0, X) = 0"] 11 | ] 12 | -------------------------------------------------------------------------------- /examples/tests/ArithBackground.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: Int 3 | 1 :: Int 4 | (+) :: Int -> Int -> Int 5 | (*) :: Int -> Int -> Int 6 | 7 | == Laws == 8 | 1. x * y = y * x 9 | 2. x + y = y + x 10 | 3. x * 1 = x 11 | 4. x + 0 = x 12 | 5. (x * y) * z = x * (y * z) 13 | 6. x * (y + y) = y * (x + x) 14 | 7. (x + y) + z = x + (y + z) 15 | 8. (x * y) + (x * z) = x * (y + z) 16 | 17 | -------------------------------------------------------------------------------- /examples/tests/ArithFloat.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: Float 3 | 1 :: Float 4 | (+) :: Float -> Float -> Float 5 | (*) :: Float -> Float -> Float 6 | (/) :: Float -> Float -> Float 7 | 8 | == Laws == 9 | 1. x * y = y * x 10 | 2. x + y = y + x 11 | 3. x * 0 = 0 12 | 4. x * 1 = x 13 | 5. x + 0 = x 14 | 6. x / 1 = x 15 | 7. x * (y + y) = y * (x + x) 16 | 8. x + (1 / 0) = y + (1 / 0) 17 | 9. x / (1 / 0) = y / (1 / 0) 18 | 10. 0 / (1 / x) = x / (1 / 0) 19 | 11. (1 / 0) / x = (1 / x) / 0 20 | 12. (1 + 1) / 0 = x + (1 / 0) 21 | 13. (1 / 0) / 0 = x + (1 / 0) 22 | 14. (x * y) + (x * y) = x * (y + y) 23 | 15. (x + x) + (y + y) = (x + y) * (1 + 1) 24 | 16. (1 / x) + (1 / x) = (1 + 1) / x 25 | 17. (1 / 0) / (x + x) = (1 / x) * (1 / 0) 26 | 18. (1 / x) / (1 + 1) = 1 / (x + x) 27 | 19. x + (x + (x + x)) = (x + x) + (x + x) 28 | 20. x / (1 / (y + y)) = (x + x) / (1 / y) 29 | 21. (1 / (x + x)) / y = (1 / x) / (y + y) 30 | 22. x * (y / (1 + 1)) = (x * y) / (1 + 1) 31 | 23. 1 + (x + (x + 1)) = (x + x) + (1 + 1) 32 | 24. x + ((1 / y) / 0) = z + ((1 / y) / 0) 33 | 34 | *** Law (/) = (/) is false! 35 | False instances: 36 | (/) = (/) is false 37 | 38 | *** Law (/) x = (/) x is false! 39 | False instances: 40 | (/) x = (/) x is false 41 | 42 | *** Law x + y = x + y is false! 43 | False instances: 44 | x + ((1 / (1 / 0)) / 0) = x + ((1 / (1 / 0)) / 0) is false 45 | 0 + ((1 / (1 / 0)) / 0) = 0 + ((1 / (1 / 0)) / 0) is false 46 | (x / y) + 0 = (x / y) + 0 is false 47 | (x / y) + (1 / 0) = (x / y) + (1 / 0) is false 48 | (1 / 0) + ((1 / (1 / 0)) / 0) = (1 / 0) + ((1 / (1 / 0)) / 0) is false 49 | ((1 / (1 / 0)) / 0) + 0 = ((1 / (1 / 0)) / 0) + 0 is false 50 | ((1 / (1 / 0)) / 0) + (1 / 0) = ((1 / (1 / 0)) / 0) + (1 / 0) is false 51 | 52 | *** Law x + y = y + x is false! 53 | False instances: 54 | 0 + ((1 / (1 / 0)) / 0) = ((1 / (1 / 0)) / 0) + 0 is false 55 | ((1 / (1 / 0)) / 0) + (1 / 0) = (1 / 0) + ((1 / (1 / 0)) / 0) is false 56 | 57 | *** Law x + 0 = x is false! 58 | False instances: 59 | (x / y) + 0 = x / y is false 60 | ((1 / (1 / 0)) / 0) + 0 = (1 / (1 / 0)) / 0 is false 61 | 62 | *** Law x + (1 / 0) = y + (1 / 0) is false! 63 | False instances: 64 | (x / y) + (1 / 0) = z + (1 / 0) is false 65 | ((1 / (1 / 0)) / 0) + (1 / 0) = x + (1 / 0) is false 66 | 67 | *** Law x + ((1 / y) / 0) = z + ((1 / y) / 0) is false! 68 | False instances: 69 | x + ((1 / (1 / 0)) / 0) = x + ((1 / (1 / 0)) / 0) is false 70 | 0 + ((1 / (1 / 0)) / 0) = x + ((1 / (1 / 0)) / 0) is false 71 | (1 / 0) + ((1 / (1 / 0)) / 0) = x + ((1 / (1 / 0)) / 0) is false 72 | 73 | *** Law x / y = x / y is false! 74 | False instances: 75 | x / y = x / y is false 76 | 0 / (1 / (1 / 0)) = 0 / (1 / (1 / 0)) is false 77 | (1 / 0) / (1 / 0) = (1 / 0) / (1 / 0) is false 78 | (1 / (1 / 0)) / 0 = (1 / (1 / 0)) / 0 is false 79 | 80 | *** Law x / (1 / 0) = y / (1 / 0) is false! 81 | False instances: 82 | (1 / 0) / (1 / 0) = x / (1 / 0) is false 83 | 84 | *** Law 0 / (1 / x) = x / (1 / 0) is false! 85 | False instances: 86 | 0 / (1 / (1 / 0)) = (1 / 0) / (1 / 0) is false 87 | 88 | -------------------------------------------------------------------------------- /examples/tests/Bicomplex.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: BiComplex 3 | 1 :: BiComplex 4 | (-) :: BiComplex -> BiComplex 5 | (*) :: BiComplex -> BiComplex -> BiComplex 6 | 7 | == Laws == 8 | 1. -0 = 0 9 | 2. x * y = y * x 10 | 3. x * 0 = 0 11 | 4. x * 1 = x 12 | 5. --x = x 13 | 6. x * -y = -(x * y) 14 | 7. (x * y) * z = x * (y * z) 15 | 16 | == Functions == 17 | real :: BiComplex -> Bool 18 | True :: Bool 19 | 20 | == Laws == 21 | 8. real 0 22 | 9. real 1 23 | 10. real -x = real x 24 | 11. real (x * (x * x)) = real x 25 | 26 | == Functions == 27 | conj1 :: BiComplex -> BiComplex 28 | conj2 :: BiComplex -> BiComplex 29 | conj3 :: BiComplex -> BiComplex 30 | 31 | == Laws == 32 | 12. conj1 0 = 0 33 | 13. conj1 1 = 1 34 | 14. conj2 0 = 0 35 | 15. conj2 1 = 1 36 | 16. conj3 0 = 0 37 | 17. conj3 1 = 1 38 | 18. conj1 -x = -(conj1 x) 39 | 19. conj1 (conj1 x) = x 40 | 20. conj3 x = conj1 (conj2 x) 41 | 21. conj2 -x = -(conj2 x) 42 | 22. conj3 x = conj2 (conj1 x) 43 | 23. conj2 (conj2 x) = x 44 | 24. real (conj1 x) = real x 45 | 25. real (conj2 x) = real x 46 | 26. conj1 x * conj1 y = conj1 (x * y) 47 | 27. conj2 x * conj2 y = conj2 (x * y) 48 | 28. real (conj2 x * (y * z)) = real (conj1 x * (y * z)) 49 | 29. real (conj1 x * (y * z)) = real (conj1 y * (x * z)) 50 | 51 | == Functions == 52 | norm1 :: BiComplex -> BiComplex 53 | norm2 :: BiComplex -> BiComplex 54 | 55 | == Laws == 56 | 30. norm1 0 = 0 57 | 31. norm1 1 = 1 58 | 32. norm2 0 = 0 59 | 33. norm2 1 = 1 60 | 34. conj1 (norm1 x) = norm1 x 61 | 35. conj2 (norm2 x) = norm2 x 62 | 36. norm1 -x = norm1 x 63 | 37. norm1 (conj1 x) = norm1 x 64 | 38. norm1 (conj2 x) = conj2 (norm1 x) 65 | 39. norm2 -x = norm2 x 66 | 40. norm2 (conj1 x) = conj1 (norm2 x) 67 | 41. norm2 (conj2 x) = norm2 x 68 | 42. norm2 (norm1 x) = norm1 (norm2 x) 69 | 43. norm1 (x * x) = norm1 (norm1 x) 70 | 44. norm2 (x * x) = norm2 (norm2 x) 71 | 45. norm1 x = x * conj1 x 72 | 46. norm2 x = x * conj2 x 73 | 47. norm1 x * norm1 y = norm1 (x * y) 74 | 48. norm2 x * norm2 y = norm2 (x * y) 75 | 49. real (norm1 (norm1 (norm1 (norm1 x)))) = real (norm1 (norm1 (norm1 x))) 76 | 50. x * conj3 (y * norm1 x) = conj3 (x * y) * norm2 x 77 | 51. x * conj3 (y * norm2 x) = conj3 (x * y) * norm1 x 78 | 52. real (norm1 (x * norm1 (norm1 x))) = real (norm1 x) 79 | 53. real (x * norm1 (norm1 (norm1 y))) = real (x * norm1 (norm1 y)) 80 | 81 | == Functions == 82 | 10 :: BiComplex 83 | 84 | == Laws == 85 | 54. conj1 10 = 10 86 | 55. conj2 10 = 10 87 | 56. real 10 88 | 57. real (norm1 10) 89 | 58. real (x * 10) = real x 90 | 59. conj2 x * norm1 (x * 10) = conj1 x * norm2 (x * 10) 91 | 60. norm1 x * conj2 (y * 10) = 10 * (conj2 y * norm1 x) 92 | 61. norm1 x * conj3 (y * 10) = 10 * (conj3 y * norm1 x) 93 | 62. norm2 x * conj1 (y * 10) = 10 * (conj1 y * norm2 x) 94 | 63. norm2 x * conj3 (y * 10) = 10 * (conj3 y * norm2 x) 95 | 64. x * conj1 (norm2 (x * 10)) = conj3 x * norm1 (x * 10) 96 | 65. x * conj2 (norm1 (x * 10)) = conj3 x * norm2 (x * 10) 97 | 98 | == Functions == 99 | i :: BiComplex 100 | h :: BiComplex 101 | ih :: BiComplex 102 | 103 | == Laws == 104 | 66. conj1 h = h 105 | 67. conj1 i = -i 106 | 68. conj1 ih = -ih 107 | 69. conj2 h = -h 108 | 70. conj2 i = i 109 | 71. conj2 ih = -ih 110 | 72. norm1 h = -1 111 | 73. norm1 i = 1 112 | 74. norm1 ih = -1 113 | 75. real i = real h 114 | 76. real ih = real h 115 | 77. ih = h * i 116 | 78. real (ih * norm1 x) = real (i * norm1 x) 117 | 79. real (i * norm1 (norm1 x)) = real (i * norm1 x) 118 | 80. conj2 (x * ih) * norm1 x = conj1 (x * ih) * norm2 x 119 | 81. norm1 x * conj2 (y * 10) = 10 * (conj2 y * norm1 x) 120 | 82. norm1 x * conj2 (y * i) = i * (conj2 y * norm1 x) 121 | 83. norm1 x * conj3 (y * 10) = 10 * (conj3 y * norm1 x) 122 | 84. norm1 x * conj3 (y * ih) = ih * (conj3 y * norm1 x) 123 | 85. norm2 x * conj1 (y * 10) = 10 * (conj1 y * norm2 x) 124 | 86. norm2 x * conj1 (y * h) = h * (conj1 y * norm2 x) 125 | 87. norm2 x * conj3 (y * 10) = 10 * (conj3 y * norm2 x) 126 | 88. norm2 x * conj3 (y * ih) = ih * (conj3 y * norm2 x) 127 | 89. ih * conj1 (ih * norm2 x) = -(conj1 (norm2 x)) 128 | 90. ih * conj2 (ih * norm1 x) = -(conj2 (norm1 x)) 129 | 91. conj1 (ih * norm2 x) * ih = -(conj1 (norm2 x)) 130 | 92. conj2 (ih * norm1 x) * ih = -(conj2 (norm1 x)) 131 | 132 | -------------------------------------------------------------------------------- /examples/tests/BinarySearch.output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nick8325/quickspec/dc011cd737f98b8a67f6051560d9fce553385905/examples/tests/BinarySearch.output -------------------------------------------------------------------------------- /examples/tests/Bools.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | not :: Bool -> Bool 3 | True :: Bool 4 | False :: Bool 5 | (||) :: Bool -> Bool -> Bool 6 | (&&) :: Bool -> Bool -> Bool 7 | 8 | == Laws == 9 | 1. not x => x = False 10 | 2. False = not True 11 | 3. x && y = y && x 12 | 4. x && x = x 13 | 5. x || y = y || x 14 | 6. x || x = x 15 | 7. x && False = False 16 | 8. x && True = x 17 | 9. x || False = x 18 | 10. x || True 19 | 11. not (not x) = x 20 | 12. x && not x = False 21 | 13. x || not x 22 | 14. (x && y) && z = x && (y && z) 23 | 15. x && (x || y) = x 24 | 16. x || (x && y) = x 25 | 17. (x || y) || z = x || (y || z) 26 | 18. not x && not y = not (x || y) 27 | 19. not x && (x || y) = y && not x 28 | 20. (x || y) && (x || z) = x || (y && z) 29 | 30 | -------------------------------------------------------------------------------- /examples/tests/Combinators.hs: -------------------------------------------------------------------------------- 1 | import QuickSpec 2 | 3 | main = quickSpec [ 4 | con "s" ((\x y z -> x z (y z)) :: (A -> B -> C) -> (A -> B) -> A -> C), 5 | con "k" (const :: A -> B -> A), 6 | con "i" (id :: A -> A) ] 7 | -------------------------------------------------------------------------------- /examples/tests/Combinators.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | s :: (a -> b -> c) -> (a -> b) -> a -> c 3 | k :: a -> b -> a 4 | i :: a -> a 5 | 6 | == Laws == 7 | 1. i x = x 8 | 2. k x y = x 9 | 3. s k f = i 10 | 4. s f i x = f x x 11 | 5. s (k f) i = f 12 | 6. s (k i) f = f 13 | 7. f x (g x) = s f g x 14 | 8. s (k f) (k x) = k (f x) 15 | 9. s (k (k x)) f = k x 16 | 10. s (k (s (k f) g)) h = s (k f) (s (k g) h) 17 | 18 | -------------------------------------------------------------------------------- /examples/tests/Composition-bad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, TypeApplications #-} 2 | 3 | import QuickSpec 4 | import Test.QuickCheck 5 | import Prelude hiding (fst) 6 | 7 | newtype Queue a = Queue [a] deriving (Eq, Ord, Arbitrary, CoArbitrary) 8 | nil = Queue [] 9 | enq x (Queue ys) = Queue (ys ++ [x]) 10 | deq (Queue (x:xs)) = Queue xs 11 | fst (Queue (x:xs)) = x 12 | 13 | main = quickSpec [ 14 | {-background-} signature [ 15 | con "." ((.) @(Queue A) @(Queue A) @(Queue A))], 16 | --con "id" (id @(Queue A)) ], 17 | 18 | inst (Sub Dict :: Ord A :- Ord (Queue A)), 19 | inst (Sub Dict :: Arbitrary A :- Arbitrary (Queue A)), 20 | inst (Sub Dict :: CoArbitrary A :- CoArbitrary (Queue A)) 21 | --"enq" `con` (enq :: A -> Queue A -> Queue A), 22 | --"deq" `con` (deq :: Queue A -> Queue A), 23 | --"fst" `con` (fst :: Queue A -> A), 24 | --"nil" `con` (nil :: Queue A) 25 | ] 26 | -------------------------------------------------------------------------------- /examples/tests/Composition-bad.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (.) :: (Queue a -> Queue a) -> (Queue a -> Queue a) -> Queue a -> Queue a 3 | 4 | == Laws == 5 | 1. (f . g) x = f (g x) 6 | 2. (f . g) . h = f . (g . h) 7 | 8 | -------------------------------------------------------------------------------- /examples/tests/Composition.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | id :: a -> a 3 | (.) :: (a -> b) -> (c -> a) -> c -> b 4 | 5 | == Laws == 6 | 1. id x = x 7 | 2. f . id = f 8 | 3. id . f = f 9 | 4. (f . g) x = f (g x) 10 | 5. (f . g) . h = f . (g . h) 11 | 12 | -------------------------------------------------------------------------------- /examples/tests/Const.hs: -------------------------------------------------------------------------------- 1 | import QuickSpec 2 | 3 | main = quickSpec [ 4 | con "const" (const :: A -> B -> A), 5 | con "asTypeOf" (asTypeOf :: A -> A -> A) ] 6 | -------------------------------------------------------------------------------- /examples/tests/Const.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | const :: a -> b -> a 3 | asTypeOf :: a -> a -> a 4 | 5 | == Laws == 6 | 1. asTypeOf x y = x 7 | 2. const x y = x 8 | 9 | -------------------------------------------------------------------------------- /examples/tests/Curry.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | curry :: ((a, b) -> c) -> a -> b -> c 3 | fst :: (a, b) -> a 4 | snd :: (a, b) -> b 5 | id :: a -> a 6 | (.) :: (a -> b) -> (c -> a) -> c -> b 7 | (|) :: (a -> b) -> (a -> c) -> a -> (b, c) 8 | 9 | == Laws == 10 | 1. id x = x 11 | 2. f . id = f 12 | 3. id . f = f 13 | 4. curry snd x = id 14 | 5. fst | snd = id 15 | 6. (f . g) x = f (g x) 16 | 7. curry fst x y = x 17 | 8. (id | id) x = curry id x x 18 | 9. fst ((f | g) x) = f x 19 | 10. snd ((f | g) x) = g x 20 | 11. fst (curry id x y) = x 21 | 12. snd (curry id x y) = y 22 | 13. (f . g) . h = f . (g . h) 23 | 14. curry (f . g) x = f . curry g x 24 | 15. (id | id) (fst x) = (fst | fst) x 25 | 16. (id | id) (snd x) = (snd | snd) x 26 | 17. f . curry fst x = curry fst (f x) 27 | 18. curry fst x . f = curry fst x 28 | 19. (id | f) . g = g | (f . g) 29 | 20. (f | id) . g = (f . g) | g 30 | 21. curry id x . f = curry fst x | f 31 | 22. fst . (f | g) = f 32 | 23. snd . (f | g) = g 33 | 24. curry (snd | f) x = id | curry f x 34 | 25. curry (f | snd) x = curry f x | id 35 | 26. curry fst x . snd = curry fst x . fst 36 | 27. curry f x (g x) = f ((id | g) x) 37 | 28. curry f (g x) x = f ((g | id) x) 38 | 29. curry f (fst x) (snd x) = f x 39 | 30. curry f (snd x) (fst x) = f ((snd | fst) x) 40 | 31. (f | curry fst x) y = curry id (f y) x 41 | 32. curry (fst | f) x x = (id | curry f x) x 42 | 33. curry (f | fst) x x = (curry f x | id) x 43 | 34. curry f (g x) (fst x) = f ((g | fst) x) 44 | 35. curry f (g x) (fst x) = f ((g | fst) x) 45 | 36. curry f (g x) (snd x) = f ((g | snd) x) 46 | 37. curry f (g x) (snd x) = f ((g | snd) x) 47 | 38. curry f (fst x) (g x) = f ((fst | g) x) 48 | 39. curry f (fst x) (g x) = f ((fst | g) x) 49 | 40. curry f (snd x) (g x) = f ((snd | g) x) 50 | 41. curry f (snd x) (g x) = f ((snd | g) x) 51 | 42. curry id x (fst (f x)) = (id | (fst . f)) x 52 | 43. curry id x (snd (f x)) = (id | (snd . f)) x 53 | 44. curry id (fst (f x)) x = ((fst . f) | id) x 54 | 45. curry id (snd (f x)) x = ((snd . f) | id) x 55 | 46. curry id x (curry f x y) = curry (fst | f) x y 56 | 47. curry id x (curry f y x) = (id | curry f y) x 57 | 48. curry id (curry f x y) x = curry (f | fst) x y 58 | 49. curry id (curry f x y) y = (curry f x | id) y 59 | 50. (snd | f) ((g | g) x) = (fst | f) ((g | g) x) 60 | 51. (f | snd) ((g | g) x) = (f | fst) ((g | g) x) 61 | 52. (snd | fst) ((f | g) x) = (g | f) x 62 | 53. (f . g) | (h . g) = (f | h) . g 63 | 54. curry f x | curry g x = curry (f | g) x 64 | 55. (f | f) . curry fst x = curry (fst | fst) (f x) 65 | 56. (snd | f) . (g | g) = (fst | f) . (g | g) 66 | 57. (f | snd) . (g | g) = (f | fst) . (g | g) 67 | 58. (snd | fst) . (f | g) = g | f 68 | 59. f | (g . (f | h)) = (fst | g) . (f | h) 69 | 60. f | (g . (h | f)) = (snd | g) . (h | f) 70 | 61. (f . (g | h)) | g = (f | fst) . (g | h) 71 | 62. (f . (g | h)) | h = (f | snd) . (g | h) 72 | 63. curry (f | (g . snd)) x = curry f x | g 73 | 64. curry ((f . snd) | g) x = f | curry g x 74 | 65. curry (fst | fst) x . snd = curry (fst | fst) x . fst 75 | 76 | -------------------------------------------------------------------------------- /examples/tests/DecisionTrees.output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nick8325/quickspec/dc011cd737f98b8a67f6051560d9fce553385905/examples/tests/DecisionTrees.output -------------------------------------------------------------------------------- /examples/tests/GCD.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: Natural 3 | 1 :: Natural 4 | (+) :: Natural -> Natural -> Natural 5 | (*) :: Natural -> Natural -> Natural 6 | 7 | == Laws == 8 | 1. x * y = y * x 9 | 2. x + y = y + x 10 | 3. x * 0 = 0 11 | 4. x * 1 = x 12 | 5. x + 0 = x 13 | 6. (x * y) * z = x * (y * z) 14 | 7. x * (y + y) = y * (x + x) 15 | 8. (x + y) + z = x + (y + z) 16 | 9. x * (y + 1) = x + (x * y) 17 | 10. (x * y) + (x * z) = x * (y + z) 18 | 19 | == Functions == 20 | gcd :: Natural -> Natural -> Natural 21 | 22 | == Laws == 23 | 11. gcd x y = gcd y x 24 | 12. gcd x x = x 25 | 13. gcd x 0 = x 26 | 14. gcd x 1 = 1 27 | 15. gcd x (x * y) = x 28 | 16. gcd x (x + y) = gcd x y 29 | 17. gcd (gcd x y) z = gcd x (gcd y z) 30 | 18. gcd (x * y) (x * z) = x * gcd y z 31 | 19. gcd (x * x) (y * y) = gcd x y * gcd x y 32 | 20. gcd (x * y) (z + y) = gcd (x * z) (z + y) 33 | 21. gcd (x + x) (y + y) = gcd x y + gcd x y 34 | 22. gcd (x + y) (y + y) = gcd (x + x) (x + y) 35 | 23. gcd (x * x) (1 + 1) = gcd x (1 + 1) 36 | 37 | -------------------------------------------------------------------------------- /examples/tests/Geometry.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | over :: Drawing -> Drawing -> Drawing 3 | 4 | == Laws == 5 | 1. over x y = over y x 6 | 2. over x x = x 7 | 3. over (over x y) z = over x (over y z) 8 | 9 | == Functions == 10 | beside :: Drawing -> Drawing -> Drawing 11 | above :: Drawing -> Drawing -> Drawing 12 | 13 | == Laws == 14 | 4. above (beside x y) (beside z w) = beside (above x z) (above y w) 15 | 5. over (above x y) (above z w) = above (over x z) (over y w) 16 | 6. over (beside x y) (beside z w) = beside (over x z) (over y w) 17 | 18 | == Functions == 19 | rot :: Drawing -> Drawing 20 | 21 | == Laws == 22 | 7. above (rot x) (rot y) = rot (beside y x) 23 | 8. beside (rot x) (rot y) = rot (above x y) 24 | 9. over (rot x) (rot y) = rot (over x y) 25 | 10. rot (rot (rot (rot x))) = x 26 | 27 | == Functions == 28 | flip :: Drawing -> Drawing 29 | 30 | == Laws == 31 | 11. flip (flip x) = x 32 | 12. rot (flip (rot x)) = flip x 33 | 13. above (flip x) (flip y) = flip (above x y) 34 | 14. over (flip x) (flip y) = flip (over x y) 35 | 36 | == Functions == 37 | cycle :: Drawing -> Drawing 38 | quartet :: Drawing -> Drawing -> Drawing -> Drawing -> Drawing 39 | 40 | == Laws == 41 | 15. rot (cycle x) = cycle x 42 | 16. cycle (rot (flip x)) = flip (cycle x) 43 | 17. over (cycle x) (cycle y) = cycle (over x y) 44 | 18. quartet x y z w = above (beside x y) (beside z w) 45 | 46 | == Functions == 47 | rot45 :: Drawing -> Drawing 48 | 49 | == Laws == 50 | 19. rot45 (flip (cycle x)) = flip (rot45 (cycle x)) 51 | 20. rot45 (flip (rot x)) = flip (rot45 x) 52 | 21. over (rot45 x) (rot45 y) = rot45 (over x y) 53 | 22. cycle (rot (rot (rot45 (flip x)))) = cycle (flip (rot (rot45 (rot x)))) 54 | 23. rot45 (rot (rot45 (rot (flip x)))) = rot (flip (rot45 (rot (rot45 x)))) 55 | 24. cycle (flip (rot (rot (rot45 (flip x))))) = cycle (flip (rot (flip (rot45 (rot x))))) 56 | 25. cycle (flip (rot (rot (rot45 (rot x))))) = cycle (flip (rot (flip (rot45 (flip x))))) 57 | 26. cycle (rot (rot (rot45 (rot45 (flip x))))) = cycle (flip (rot (rot45 (rot45 (rot x))))) 58 | 27. cycle (rot (rot (rot45 (rot45 (rot x))))) = cycle (flip (rot (rot45 (rot45 (flip x))))) 59 | 28. cycle (rot (rot45 (rot45 (rot45 (flip x))))) = cycle (flip (rot45 (rot45 (rot45 (rot x))))) 60 | 29. cycle (rot (rot45 (rot45 (rot45 (rot x))))) = cycle (flip (rot45 (rot45 (rot45 (flip x))))) 61 | 30. rot (rot (rot45 (rot (rot45 (flip x))))) = flip (rot (rot45 (rot (rot45 (rot x))))) 62 | 31. rot (rot (rot45 (rot (rot45 (rot x))))) = flip (rot (rot45 (rot (rot45 (flip x))))) 63 | 32. rot45 (rot (rot45 (rot45 (rot (rot x))))) = rot (rot45 (rot (rot45 (rot (rot45 x))))) 64 | 33. rot45 (rot45 (rot45 (rot45 (rot (flip x))))) = rot (flip (rot45 (rot45 (rot45 (rot45 x))))) 65 | 66 | == Functions == 67 | blank :: Drawing 68 | 69 | == Laws == 70 | 34. cycle blank = blank 71 | 35. flip blank = blank 72 | 36. rot45 blank = blank 73 | 37. over x blank = x 74 | 38. above blank blank = blank 75 | 39. quartet (cycle x) blank blank blank = rot45 (rot (rot45 (cycle x))) 76 | 40. above blank (rot45 (rot (rot x))) = rot (rot (above blank (rot45 x))) 77 | 41. above (rot45 (rot45 (rot45 x))) blank = rot45 (rot45 (beside (rot45 x) blank)) 78 | 42. beside (rot45 (rot45 (rot45 x))) blank = rot45 (rot45 (above (rot45 x) blank)) 79 | 43. rot (rot (rot45 (rot (rot45 x)))) = quartet blank blank blank x 80 | 44. rot (rot45 (rot (rot (rot45 x)))) = quartet x blank blank blank 81 | 45. quartet blank (flip x) (flip y) blank = flip (quartet x blank blank y) 82 | 46. rot (quartet x blank blank y) = quartet blank (rot y) (rot x) blank 83 | 47. quartet (rot x) blank blank (rot y) = rot (quartet blank x y blank) 84 | 48. quartet (flip x) (flip y) z blank = flip (quartet y x blank (flip z)) 85 | 49. quartet (flip x) (flip y) blank z = flip (quartet y x (flip z) blank) 86 | 50. quartet blank (flip x) y (flip z) = flip (quartet x blank z (flip y)) 87 | 51. quartet blank (flip x) (flip y) z = flip (quartet x blank (flip z) y) 88 | 52. quartet x (flip y) blank (flip z) = flip (quartet y (flip x) z blank) 89 | 53. quartet x (flip y) (flip z) blank = flip (quartet y (flip x) blank z) 90 | 54. quartet (flip x) blank y (flip z) = flip (quartet blank x z (flip y)) 91 | 55. quartet (flip x) blank (flip y) z = flip (quartet blank x (flip z) y) 92 | 56. quartet x blank (flip y) (flip z) = flip (quartet blank (flip x) z y) 93 | 57. quartet (flip x) y blank (flip z) = flip (quartet (flip y) x z blank) 94 | 58. quartet (flip x) y (flip z) blank = flip (quartet (flip y) x blank z) 95 | 59. quartet blank x (flip y) (flip z) = flip (quartet (flip x) blank z y) 96 | 60. above blank (over x (rot45 (cycle y))) = above (rot (rot (rot45 (cycle y)))) x 97 | 61. above blank (rot45 (rot45 (rot (rot x)))) = rot (beside blank (rot45 (rot (rot45 x)))) 98 | 62. above blank (rot45 (rot45 (rot (rot45 x)))) = rot45 (rot (rot45 (above (rot45 x) blank))) 99 | 63. above (rot45 (flip (rot45 (rot45 x)))) blank = rot45 (flip (rot45 (above blank (rot45 x)))) 100 | 64. above (rot45 (rot (rot45 (rot45 x)))) blank = rot45 (rot (rot45 (above blank (rot45 x)))) 101 | 65. above (rot45 (rot45 (cycle (rot45 x)))) blank = rot45 (rot45 (beside (cycle (rot45 x)) blank)) 102 | 66. above (rot45 (rot45 (flip (rot45 x)))) blank = rot45 (rot45 (flip (beside blank (rot45 x)))) 103 | 67. above (rot45 (rot45 (rot (rot45 x)))) blank = rot45 (rot45 (rot (above (rot45 x) blank))) 104 | 68. beside (rot45 (flip (rot45 (rot45 x)))) blank = rot45 (flip (rot45 (beside blank (rot45 x)))) 105 | 69. beside (rot45 (rot (rot45 (rot45 x)))) blank = rot45 (rot (rot45 (beside blank (rot45 x)))) 106 | 70. beside (rot45 (rot45 (cycle (rot45 x)))) blank = rot45 (rot45 (above (cycle (rot45 x)) blank)) 107 | 71. beside (rot45 (rot45 (flip (rot45 x)))) blank = rot45 (rot45 (flip (above (rot45 x) blank))) 108 | 72. beside (rot45 (rot45 (rot (rot45 x)))) blank = rot45 (rot45 (rot (beside blank (rot45 x)))) 109 | 73. flip (rot45 (rot (rot45 (rot45 (flip x))))) = quartet blank blank blank (rot45 (rot x)) 110 | 74. flip (rot45 (rot (rot45 (rot45 (rot x))))) = quartet blank blank blank (rot45 (flip x)) 111 | 75. rot45 (rot (rot45 (flip (rot45 (rot x))))) = quartet blank blank (rot45 (flip x)) blank 112 | 76. rot45 (rot (rot45 (rot45 (rot (flip x))))) = flip (quartet blank blank blank (rot45 x)) 113 | 114 | -------------------------------------------------------------------------------- /examples/tests/Head.hs: -------------------------------------------------------------------------------- 1 | -- Partial functions. 2 | import QuickSpec 3 | 4 | main = quickSpec [ 5 | con "head" (head :: [A] -> A), 6 | con "tail" (tail :: [A] -> [A]), 7 | con ":" ((:) :: A -> [A] -> [A])] 8 | -------------------------------------------------------------------------------- /examples/tests/Head.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | head :: [a] -> a 3 | tail :: [a] -> [a] 4 | (:) :: a -> [a] -> [a] 5 | 6 | == Laws == 7 | 1. head (x : xs) = x 8 | 2. tail (x : xs) = xs 9 | 10 | -------------------------------------------------------------------------------- /examples/tests/Heaps.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (||) :: Bool -> Bool -> Bool 3 | (&&) :: Bool -> Bool -> Bool 4 | not :: Bool -> Bool 5 | True :: Bool 6 | False :: Bool 7 | 0 :: Int 8 | 1 :: Int 9 | (+) :: Int -> Int -> Int 10 | [] :: [a] 11 | (:) :: a -> [a] -> [a] 12 | (++) :: [a] -> [a] -> [a] 13 | head :: [a] -> a 14 | tail :: [a] -> [a] 15 | toList :: Heap OrdA -> [OrdA] 16 | sort :: [OrdA] -> [OrdA] 17 | insertList :: OrdA -> [OrdA] -> [OrdA] 18 | nullList :: [OrdA] -> Bool 19 | deleteList :: OrdA -> [OrdA] -> [OrdA] 20 | mergeLists :: [OrdA] -> [OrdA] -> [OrdA] 21 | 22 | == Functions == 23 | nil :: Heap OrdA 24 | insert :: OrdA -> Heap OrdA -> Heap OrdA 25 | findMin :: Heap OrdA -> OrdA 26 | deleteMin :: Heap OrdA -> Heap OrdA 27 | merge :: Heap OrdA -> Heap OrdA -> Heap OrdA 28 | null :: Heap OrdA -> Bool 29 | fromList :: [OrdA] -> Heap OrdA 30 | True :: Bool 31 | False :: Bool 32 | 33 | == Laws == 34 | 1. null nil 35 | 2. nil = fromList [] 36 | 3. toList nil = [] 37 | 4. merge h h1 = merge h1 h 38 | 5. merge h nil = h 39 | 6. null h = nullList (toList h) 40 | 7. null (fromList xs) = nullList xs 41 | 8. fromList (sort xs) = fromList xs 42 | 9. fromList (toList h) = h 43 | 10. toList (fromList xs) = sort xs 44 | 11. null (insert x h) = False 45 | 12. null (merge h h) = null h 46 | 13. insertList x (toList h) = toList (insert x h) 47 | 14. findMin (insert x nil) = x 48 | 15. deleteMin (insert x nil) = nil 49 | 16. merge h (insert x h1) = insert x (merge h h1) 50 | 17. merge (merge h h1) h2 = merge h (merge h1 h2) 51 | 18. null h && null h1 = null (merge h h1) 52 | 19. mergeLists (toList h) (toList h1) = toList (merge h h1) 53 | 20. head (toList (insert x h)) = findMin (insert x h) 54 | 21. null (deleteMin (insert x h)) = null h 55 | 22. toList (deleteMin (insert x h)) = tail (toList (insert x h)) 56 | 23. deleteMin (insert (findMin h) h) = h 57 | 24. insert x (deleteMin (insert x h)) = deleteMin (insert x (insert x h)) 58 | 25. merge h (deleteMin (insert x h)) = deleteMin (insert x (merge h h)) 59 | 26. tail (insertList (findMin (fromList xs)) xs) = xs 60 | 27. null (merge (fromList xs) (merge h h1)) = nullList (toList h1 ++ (xs ++ ys)) 61 | 28. insertList (findMin (insert x h)) (toList h) = findMin (insert x h) : toList h 62 | 29. head (insertList (findMin (insert x h)) xs) = head (mergeLists (toList h) (insertList x xs)) 63 | 30. findMin (insert (head (insertList x xs)) h) = head (mergeLists (toList h) (insertList x xs)) 64 | 31. findMin (insert (findMin (insert x h)) h1) = findMin (insert x (merge h h1)) 65 | 32. fromList (tail (insertList x (y : xs))) = fromList (tail (insertList y (x : xs))) 66 | 33. fromList (tail (insertList x (mergeLists xs ys))) = fromList (tail (insertList x (mergeLists ys xs))) 67 | 34. fromList (tail (insertList x (mergeLists xs xs))) = fromList (tail (insertList x (xs ++ xs))) 68 | 35. fromList (tail (xs ++ insertList x xs)) = fromList (tail (xs ++ (x : xs))) 69 | 36. fromList (tail (mergeLists xs (x : ys))) = fromList (tail (insertList x xs ++ ys)) 70 | 37. fromList (tail (mergeLists (x : xs) ys)) = fromList (tail (insertList x ys ++ xs)) 71 | 38. fromList (tail (mergeLists (insertList x xs) ys)) = fromList (tail (insertList x (mergeLists xs ys))) 72 | 39. deleteMin (insert x (deleteMin (insert y h))) = deleteMin (deleteMin (insert x (insert y h))) 73 | 40. deleteMin (insert (findMin (insert x h)) h) = h 74 | 41. deleteMin (insert (findMin (merge h h1)) h) = h 75 | 42. deleteList x (tail (toList (insert x h))) = deleteList (findMin (insert x h)) (toList h) 76 | 43. deleteList (findMin (insert (head xs) h)) xs = deleteList (head (mergeLists xs (toList h))) xs 77 | 44. merge h (fromList (deleteList x (toList h))) = fromList (deleteList x (toList (merge h h))) 78 | 45. findMin (deleteMin (insert x (insert y nil))) = head (tail (insertList x (y : []))) 79 | 80 | -------------------------------------------------------------------------------- /examples/tests/HugeLists.output: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nick8325/quickspec/dc011cd737f98b8a67f6051560d9fce553385905/examples/tests/HugeLists.output -------------------------------------------------------------------------------- /examples/tests/IntSet.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | union :: IntSet -> IntSet -> IntSet 3 | intersection :: IntSet -> IntSet -> IntSet 4 | empty :: IntSet 5 | 6 | == Laws == 7 | 1. intersection x y = intersection y x 8 | 2. intersection x x = x 9 | 3. union x y = union y x 10 | 4. union x x = x 11 | 5. intersection x empty = empty 12 | 6. union x empty = x 13 | 7. intersection (intersection x y) z = intersection x (intersection y z) 14 | 8. intersection x (union x y) = x 15 | 9. union x (intersection x y) = x 16 | 10. union (union x y) z = union x (union y z) 17 | 11. intersection (union x y) (union x z) = union x (intersection y z) 18 | 19 | == Functions == 20 | insert :: Int -> IntSet -> IntSet 21 | delete :: Int -> IntSet -> IntSet 22 | 23 | == Laws == 24 | 12. delete x empty = empty 25 | 13. delete x (delete y z) = delete y (delete x z) 26 | 14. delete x (delete x y) = delete x y 27 | 15. delete x (insert x y) = delete x y 28 | 16. insert x (delete x y) = insert x y 29 | 17. insert x (insert y z) = insert y (insert x z) 30 | 18. intersection x (delete y z) = delete y (intersection x z) 31 | 19. intersection x (insert y x) = x 32 | 20. union x (insert y z) = insert y (union x z) 33 | 21. intersection (insert x y) (insert x z) = insert x (intersection y z) 34 | 22. union (delete x y) (delete x z) = delete x (union y z) 35 | 23. union x (delete y (insert z empty)) = union x (delete y (insert z x)) 36 | 24. union x (intersection y (insert z empty)) = intersection (insert z x) (union x y) 37 | 38 | == Functions == 39 | False :: Bool 40 | member :: Int -> IntSet -> Bool 41 | 42 | == Laws == 43 | 25. member x empty = False 44 | 26. member x y => insert x y = y 45 | 27. member x (delete x y) = False 46 | 28. member x (insert x y) 47 | 29. member x (insert y empty) = member y (insert x empty) 48 | 30. member x z & member y w => member x (delete y z) = member y (delete x w) 49 | 31. member x z => member x (intersection y z) = member x y 50 | 32. member x (delete y (insert x z)) = member x (delete y (insert x w)) 51 | 33. member x (delete y (insert x z)) = member y (delete x (insert y z)) 52 | 34. member x (insert y (delete x z)) = member x (insert y empty) 53 | 35. member x (intersection y (insert x z)) = member x y 54 | 36. member x (union y (delete x z)) = member x y 55 | 37. member x (delete y (insert z empty)) = member z (delete y (insert x empty)) 56 | 38. member x (intersection y (insert z empty)) = member z (intersection y (insert x empty)) 57 | 58 | -------------------------------------------------------------------------------- /examples/tests/ListHOF.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | map :: (a -> b) -> [a] -> [b] 3 | fold :: (a -> b -> b) -> b -> [a] -> b 4 | (.) :: (a -> b) -> (c -> a) -> c -> b 5 | [] :: [a] 6 | (:) :: a -> [a] -> [a] 7 | 8 | == Laws == 9 | 1. map f [] = [] 10 | 2. (f . g) x = f (g x) 11 | 3. fold f x [] = x 12 | 4. fold (:) [] xs = xs 13 | 5. map f (x : []) = f x : [] 14 | 6. map (f . g) xs = map f (map g xs) 15 | 7. (f . g) . h = f . (g . h) 16 | 8. map f . map g = map (f . g) 17 | 9. f . fold (:) [] = f 18 | 10. fold (:) [] . f = f 19 | 11. fold ((:) . f) [] = map f 20 | 12. fold f x (y : []) = f y x 21 | 13. fold (f . g) x xs = fold f x (map g xs) 22 | 14. fold (:) xs (x : ys) = x : fold (:) xs ys 23 | 15. fold f x . map g = fold (f . g) x 24 | 16. fold (:) xs . (:) x = (:) x . fold (:) xs 25 | 17. f x (fold f y xs) = fold f y (x : xs) 26 | 18. f x : map f xs = map f (x : xs) 27 | 19. f x . fold f y = fold f y . (:) x 28 | 20. (:) (f x) . map f = map f . (:) x 29 | 21. fold f (fold f x xs) ys = fold f x (fold (:) xs ys) 30 | 22. fold f (fold f x xs) = fold f x . fold (:) xs 31 | 23. fold ((:) . f) (map f xs) = map f . fold (:) xs 32 | 33 | -------------------------------------------------------------------------------- /examples/tests/ListMonad.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | return :: a -> [a] 3 | (>>=) :: [a] -> (a -> [b]) -> [b] 4 | (++) :: [a] -> [a] -> [a] 5 | (>=>) :: (a -> [b]) -> (b -> [c]) -> a -> [c] 6 | 7 | == Laws == 8 | 1. xs >>= return = xs 9 | 2. return >=> f = f 10 | 3. f >=> return = f 11 | 4. return x >>= f = f x 12 | 5. f x >>= g = (f >=> g) x 13 | 6. (xs ++ ys) ++ zs = xs ++ (ys ++ zs) 14 | 7. xs >>= (f >=> g) = (xs >>= f) >>= g 15 | 8. (f >=> g) >=> h = f >=> (g >=> h) 16 | 9. (xs >>= f) ++ f x = ((++) xs >=> f) (return x) 17 | 10. f x ++ (xs >>= f) = (return x ++ xs) >>= f 18 | 11. (xs >>= f) ++ (ys >>= f) = (xs ++ ys) >>= f 19 | 20 | -------------------------------------------------------------------------------- /examples/tests/Lists.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: Int 3 | 1 :: Int 4 | (+) :: Int -> Int -> Int 5 | 6 | == Functions == 7 | reverse :: [a] -> [a] 8 | (++) :: [a] -> [a] -> [a] 9 | [] :: [a] 10 | map :: (a -> b) -> [a] -> [b] 11 | length :: [a] -> Int 12 | concat :: [[a]] -> [a] 13 | 14 | == Laws == 15 | 1. length [] = 0 16 | 2. reverse [] = [] 17 | 3. concat [] = [] 18 | 4. xs ++ [] = xs 19 | 5. [] ++ xs = xs 20 | 6. map f [] = [] 21 | 7. length (reverse xs) = length xs 22 | 8. reverse (reverse xs) = xs 23 | 9. length (xs ++ ys) = length (ys ++ xs) 24 | 10. length (map f xs) = length xs 25 | 11. map f (reverse xs) = reverse (map f xs) 26 | 12. map ((++) []) xss = xss 27 | 13. length (concat (reverse xss)) = length (concat xss) 28 | 14. reverse (concat (reverse xss)) = concat (map reverse xss) 29 | 15. (xs ++ ys) ++ zs = xs ++ (ys ++ zs) 30 | 16. length xs + length ys = length (xs ++ ys) 31 | 17. reverse xs ++ reverse ys = reverse (ys ++ xs) 32 | 18. concat xss ++ concat yss = concat (xss ++ yss) 33 | 19. map reverse (map reverse xss) = xss 34 | 20. concat (map (map f) xss) = map f (concat xss) 35 | 21. map reverse (map (map f) xss) = map (map f) (map reverse xss) 36 | 22. map f xs ++ map f ys = map f (xs ++ ys) 37 | 23. map ((++) xs) (map ((++) ys) xss) = map ((++) (xs ++ ys)) xss 38 | 24. length (concat (map f (concat (reverse xss)))) = length (concat (map f (concat xss))) 39 | 25. length (concat (map ((++) (reverse xs)) xss)) = length (concat (map ((++) xs) xss)) 40 | 41 | -------------------------------------------------------------------------------- /examples/tests/MinMax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} 2 | import QuickSpec 3 | import Test.QuickCheck 4 | import Data.Monoid 5 | import Data.Typeable 6 | 7 | newtype Constant = Constant Integer deriving (Eq, Ord, Typeable, Num) 8 | instance Arbitrary Constant where 9 | arbitrary = fmap (Constant . getPositive) arbitrary 10 | 11 | main = quickSpec [ 12 | withMaxTermSize 9, 13 | series [sig1, sig2] ] 14 | 15 | sig1 = [ 16 | con "+" ((+) :: Integer -> Integer -> Integer), 17 | --con "negate" (negate :: Integer -> Integer), 18 | con "+" ((+) :: Constant -> Constant -> Constant), 19 | --con "0" (0 :: Integer), 20 | --con "1" (1 :: Constant), 21 | --con "2" (2 :: Constant), 22 | con "*" (\(Constant x) y -> x * y), 23 | monoTypeWithVars ["c", "d", "e"] (Proxy :: Proxy Constant) ] 24 | 25 | sig2 = [ 26 | con "min" (min :: Integer -> Integer -> Integer), 27 | con "max" (max :: Integer -> Integer -> Integer) ] 28 | -------------------------------------------------------------------------------- /examples/tests/Octonions.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (*) :: It -> It -> It 3 | inv :: It -> It 4 | 1 :: It 5 | 6 | == Laws == 7 | 1. inv 1 = 1 8 | 2. x * 1 = x 9 | 3. 1 * x = x 10 | 4. inv (inv x) = x 11 | 5. x * inv x = 1 12 | 6. (x * x) * y = x * (x * y) 13 | 7. (x * y) * x = x * (y * x) 14 | 8. (x * y) * y = x * (y * y) 15 | 9. inv x * inv y = inv (y * x) 16 | 10. inv x * (x * y) = y 17 | 11. x * (y * (y * x)) = (x * y) * (y * x) 18 | 12. x * (y * (y * y)) = (x * y) * (y * y) 19 | 13. x * ((y * z) * x) = (x * y) * (z * x) 20 | 14. (x * (y * x)) * z = x * (y * (x * z)) 21 | 15. ((x * y) * z) * y = x * (y * (z * y)) 22 | 23 | -------------------------------------------------------------------------------- /examples/tests/Pairs.hs: -------------------------------------------------------------------------------- 1 | -- Just for testing polymorphic generalisation 2 | 3 | import QuickSpec 4 | import Data.Monoid 5 | 6 | main = 7 | quickSpec [series [sig1, sig2]] 8 | where 9 | sig1 = [ 10 | con "," ((,) :: A -> B -> (A, B)), 11 | con "fst" (fst :: (A, B) -> A), 12 | con "snd" (snd :: (A, B) -> B) ] 13 | sig2 = [ 14 | con "pair" (True, 'a')] 15 | -------------------------------------------------------------------------------- /examples/tests/Pairs.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (,) :: a -> b -> (a, b) 3 | fst :: (a, b) -> a 4 | snd :: (a, b) -> b 5 | 6 | == Laws == 7 | 1. fst (x, y) = x 8 | 2. snd (x, y) = y 9 | 3. (fst x, snd x) = x 10 | 11 | == Functions == 12 | pair :: (Bool, Char) 13 | 14 | == Laws == 15 | 16 | -------------------------------------------------------------------------------- /examples/tests/PredicateBackground.hs: -------------------------------------------------------------------------------- 1 | -- Testing that discovered conditional laws can be given as background theory. 2 | import QuickSpec 3 | import QuickSpec.Internal 4 | import Twee.Pretty 5 | import Data.List 6 | 7 | sorted :: Ord a => [a] -> Bool 8 | sorted [] = True 9 | sorted [_] = True 10 | sorted (x:y:xs) = x <= y && sorted (y:xs) 11 | 12 | sig = signature [ 13 | lists `without` ["++"], 14 | con "sort" (sort :: [Int] -> [Int]), 15 | con "insert" (insert :: Int -> [Int] -> [Int]), 16 | predicate "sorted" (sorted :: [Int] -> Bool) ] 17 | 18 | main = do 19 | thy <- quickSpecResult sig 20 | quickSpec (sig `mappend` addBackground thy) 21 | -------------------------------------------------------------------------------- /examples/tests/PredicateBackground.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | [] :: [a] 3 | (:) :: a -> [a] -> [a] 4 | 5 | == Functions == 6 | sort :: [Int] -> [Int] 7 | insert :: Int -> [Int] -> [Int] 8 | sorted :: [Int] -> Bool 9 | 10 | == Laws == 11 | 1. sorted [] 12 | 2. sort [] = [] 13 | 3. sorted xs => sort xs = xs 14 | 4. insert x [] = x : [] 15 | 5. sorted (sort xs) 16 | 6. sorted (insert x xs) = sorted xs 17 | 7. sort (insert x xs) = sort (x : xs) 18 | 8. insert x (sort xs) = sort (x : xs) 19 | 9. insert x (x : xs) = x : (x : xs) 20 | 10. insert x (insert y xs) = insert y (insert x xs) 21 | 11. sorted (x : insert x xs) = sorted (x : xs) 22 | 23 | == Functions == 24 | [] :: [a] 25 | (:) :: a -> [a] -> [a] 26 | 27 | == Functions == 28 | sort :: [Int] -> [Int] 29 | insert :: Int -> [Int] -> [Int] 30 | sorted :: [Int] -> Bool 31 | 32 | == Laws == 33 | 34 | -------------------------------------------------------------------------------- /examples/tests/PrettyPrinting-warnings.hs: -------------------------------------------------------------------------------- 1 | -- Test case for warning generation. 2 | {-# LANGUAGE DeriveDataTypeable, TypeOperators, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 3 | import Prelude hiding ((<>)) 4 | import Control.Monad 5 | import Test.QuickCheck 6 | import QuickSpec 7 | import Text.PrettyPrint.HughesPJ hiding (Str) 8 | import Data.Proxy 9 | import Data.Constraint 10 | 11 | deriving instance Typeable Doc 12 | 13 | instance Arbitrary Doc where 14 | arbitrary = 15 | sized $ \n -> 16 | let bin = resize (n `div` 2) arbitrary 17 | un = resize (n-1) arbitrary in 18 | oneof $ 19 | [ liftM2 ($$) bin bin | n > 0 ] ++ 20 | [ liftM2 (<>) bin bin | n > 0 ] ++ 21 | [ liftM2 nest arbitrary un | n > 0 ] ++ 22 | [ fmap text arbitrary ] 23 | 24 | -- Observational equality. 25 | instance Observe Context Str Doc where 26 | observe (Context ctx) d = Str (render (ctx d)) 27 | newtype Str = Str String deriving (Eq, Ord) 28 | 29 | newtype Context = Context (Doc -> Doc) 30 | 31 | instance Arbitrary Context where 32 | arbitrary = Context <$> ctx 33 | where 34 | ctx = 35 | sized $ \n -> 36 | oneof $ 37 | [ return id ] ++ 38 | [ liftM2 (\x y d -> op (x d) y) (resize (n `div` 2) ctx) (resize (n `div` 2) arbitrary) | n > 0, op <- [(<>), ($$)] ] ++ 39 | [ liftM2 (\x y d -> op x (y d)) (resize (n `div` 2) arbitrary) (resize (n `div` 2) ctx) | n > 0, op <- [(<>), ($$)] ] ++ 40 | [ liftM2 (\x y d -> nest x (y d)) arbitrary (resize (n-1) ctx) | n > 0 ] 41 | 42 | unindented :: Doc -> Bool 43 | unindented d = render (nest 100 (text "" <> d)) == render (nest 100 d) 44 | 45 | nesting :: Doc -> Int 46 | nesting d = head [ i | i <- nums, unindented (nest (-i) d) ] 47 | where 48 | nums = 0:concat [ [i, -i] | i <- [1..] ] 49 | 50 | main = quickSpec [ 51 | withMaxTermSize 9, 52 | 53 | background [ 54 | con "[]" ([] :: [A]), 55 | con "++" ((++) :: [A] -> [A] -> [A]), 56 | con "0" (0 :: Int), 57 | con "+" ((+) :: Int -> Int -> Int), 58 | con "length" (length :: [A] -> Int) ], 59 | 60 | 61 | con "text" text, 62 | con "nest" nest, 63 | --con "nesting" nesting, 64 | con "<>" (<>), 65 | con "$$" ($$), 66 | 67 | defaultTo (Proxy :: Proxy Bool)] 68 | -------------------------------------------------------------------------------- /examples/tests/PrettyPrinting-warnings.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | [] :: [a] 3 | (++) :: [a] -> [a] -> [a] 4 | 0 :: Int 5 | (+) :: Int -> Int -> Int 6 | length :: [a] -> Int 7 | 8 | == Functions == 9 | text :: [Char] -> Doc 10 | nest :: Int -> Doc -> Doc 11 | (<>) :: Doc -> Doc -> Doc 12 | ($$) :: Doc -> Doc -> Doc 13 | 14 | WARNING: The following types have no 'Arbitrary' instance declared. 15 | You will not get any variables of the following types: 16 | Doc 17 | 18 | WARNING: The following types have no 'Ord' or 'Observe' instance declared. 19 | You will not get any equations about the following types: 20 | Doc 21 | 22 | == Laws == 23 | 24 | -------------------------------------------------------------------------------- /examples/tests/PrettyPrinting.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | [] :: [a] 3 | (++) :: [a] -> [a] -> [a] 4 | 0 :: Int 5 | (+) :: Int -> Int -> Int 6 | length :: [a] -> Int 7 | 8 | == Functions == 9 | text :: [Char] -> Doc 10 | nest :: Int -> Doc -> Doc 11 | (<>) :: Doc -> Doc -> Doc 12 | ($$) :: Doc -> Doc -> Doc 13 | 14 | == Laws == 15 | 1. nest 0 x = x 16 | 2. x <> text [] = x 17 | 3. nest x (nest y z) = nest y (nest x z) 18 | 4. nest (x + y) z = nest x (nest y z) 19 | 5. (x $$ y) $$ z = x $$ (y $$ z) 20 | 6. x <> nest y z = x <> z 21 | 7. nest x y <> z = nest x (y <> z) 22 | 8. (x $$ y) <> z = x $$ (y <> z) 23 | 9. (x <> y) <> z = x <> (y <> z) 24 | 10. text xs <> text ys = text (xs ++ ys) 25 | 11. nest x y $$ nest x z = nest x (y $$ z) 26 | 12. text xs $$ nest (length xs) x = text xs <> (text [] $$ x) 27 | 13. text [] <> (text xs $$ x) = text xs $$ x 28 | 14. text (xs ++ ys) $$ nest (length xs) x = text xs <> (text ys $$ x) 29 | 15. (text [] <> x) $$ (text [] <> x) = text [] <> (x $$ x) 30 | 16. text xs <> (nest (length xs) x $$ x) = (text xs <> x) $$ (text [] <> x) 31 | 17. (text xs <> x) $$ nest (length xs) y = text xs <> ((text [] <> x) $$ y) 32 | 18. text [] <> ((text xs <> x) $$ y) = (text xs <> x) $$ y 33 | 34 | -------------------------------------------------------------------------------- /examples/tests/PrettyPrintingModel.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | "" :: [Char] 3 | (++) :: [Char] -> [Char] -> [Char] 4 | 0 :: Int 5 | (+) :: Int -> Int -> Int 6 | length :: [Char] -> Int 7 | 8 | == Functions == 9 | text :: [Char] -> Layout 10 | nest :: Int -> Layout -> Layout 11 | ($$) :: Layout -> Layout -> Layout 12 | (<>) :: Layout -> Layout -> Layout 13 | 14 | == Laws == 15 | 1. nest 0 x = x 16 | 2. x <> text "" = x 17 | 3. nest x (nest y z) = nest y (nest x z) 18 | 4. nest (x + y) z = nest x (nest y z) 19 | 5. (x $$ y) $$ z = x $$ (y $$ z) 20 | 6. x <> nest y z = x <> z 21 | 7. nest x y <> z = nest x (y <> z) 22 | 8. (x $$ y) <> z = x $$ (y <> z) 23 | 9. (x <> y) <> z = x <> (y <> z) 24 | 10. text xs <> text ys = text (xs ++ ys) 25 | 11. nest x y $$ nest x z = nest x (y $$ z) 26 | 12. text xs $$ nest (length xs) x = text xs <> (text "" $$ x) 27 | 13. text "" <> (text xs $$ x) = text xs $$ x 28 | 14. text (xs ++ ys) $$ nest (length xs) x = text xs <> (text ys $$ x) 29 | 15. (text "" <> x) $$ (text "" <> x) = text "" <> (x $$ x) 30 | 16. text xs <> (nest (length xs) x $$ x) = (text xs <> x) $$ (text "" <> x) 31 | 17. (text xs <> x) $$ nest (length xs) y = text xs <> ((text "" <> x) $$ y) 32 | 18. text "" <> ((text xs <> x) $$ y) = (text xs <> x) $$ y 33 | 34 | == Functions == 35 | nesting :: Layout -> Int 36 | 37 | == Laws == 38 | 19. nesting (text xs) = 0 39 | 20. nesting (x $$ y) = nesting x 40 | 21. nesting (x <> y) = nesting x 41 | 22. x + nesting y = nesting (nest x y) 42 | 23. nest (nesting x) (text "" <> x) = x 43 | 44 | -------------------------------------------------------------------------------- /examples/tests/Queues.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (.) :: (Queue a -> Queue a) -> (Queue a -> Queue a) -> Queue a -> Queue a 3 | id :: Queue a -> Queue a 4 | 5 | == Functions == 6 | enq :: a -> Queue a -> Queue a 7 | deq :: Queue a -> Queue a 8 | fst :: Queue a -> a 9 | nil :: Queue a 10 | 11 | == Laws == 12 | 1. fst (enq x nil) = x 13 | 2. deq (enq x nil) = nil 14 | 3. fst (enq (f x) x) = fst (enq (f nil) x) 15 | 4. fst (enq x (enq y z)) = fst (enq y z) 16 | 5. enq x (deq (enq y z)) = deq (enq x (enq y z)) 17 | 6. enq x . (deq . enq y) = deq . (enq x . enq y) 18 | 7. fst (enq (fst (enq x y)) y) = fst (enq x y) 19 | 8. deq (enq (fst (enq x y)) y) = deq (enq (fst y) y) 20 | 21 | -------------------------------------------------------------------------------- /examples/tests/Refinements.hs: -------------------------------------------------------------------------------- 1 | import QuickSpec 2 | import Test.QuickCheck hiding (NonZero) 3 | 4 | {- The universe of types -} 5 | 6 | {- type NonZero = { x : Int | x /= 0 } -} 7 | newtype NonZero = NonZero Int deriving (Ord, Eq, Show) 8 | 9 | instance Arbitrary NonZero where 10 | arbitrary = NonZero <$> arbitrary `suchThat` (/= 0) 11 | 12 | {- type Odd = { x : Int | odd x } -} 13 | newtype Odd = Odd Int deriving (Ord, Eq, Show) 14 | 15 | instance Arbitrary Odd where 16 | arbitrary = Odd <$> arbitrary `suchThat` odd 17 | 18 | {- NonZero <= Int -} 19 | nonZeroInt :: NonZero -> Int 20 | nonZeroInt (NonZero i) = i 21 | 22 | {- Odd <= Int -} 23 | oddInt :: Odd -> Int 24 | oddInt (Odd i) = i 25 | 26 | {- Odd <= NonZero -} 27 | oddNonZero :: Odd -> NonZero 28 | oddNonZero (Odd i) = NonZero i 29 | 30 | {- The functions of interest -} 31 | 32 | divide :: Int -> NonZero -> Int 33 | divide i (NonZero j) = div i j 34 | 35 | main = quickSpec [ 36 | withMaxTermSize 10, 37 | monoTypeWithVars ["x", "y", "z"] (Proxy :: Proxy NonZero), 38 | monoTypeWithVars ["x", "y", "z"] (Proxy :: Proxy Odd), 39 | con "1" (1 :: Int), 40 | con "1" (NonZero 1), 41 | con "1" (Odd 1), 42 | con "0" (0 :: Int), 43 | con "nonZeroInt" nonZeroInt, 44 | con "oddInt" oddInt, 45 | con "oddNonZero" oddNonZero, 46 | con "divide" divide ] 47 | -------------------------------------------------------------------------------- /examples/tests/Refinements.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 1 :: Int 3 | 1 :: NonZero 4 | 1 :: Odd 5 | 0 :: Int 6 | nonZeroInt :: NonZero -> Int 7 | oddInt :: Odd -> Int 8 | oddNonZero :: Odd -> NonZero 9 | divide :: Int -> NonZero -> Int 10 | 11 | == Laws == 12 | 1. 1 = nonZeroInt 1 13 | 2. 1 = oddInt 1 14 | 3. 1 = oddNonZero 1 15 | 4. divide x 1 = x 16 | 5. divide 0 x = 0 17 | 6. oddInt x = nonZeroInt (oddNonZero x) 18 | 7. divide (nonZeroInt x) x = 1 19 | 8. divide (divide (divide (nonZeroInt x) y) x) y = divide (divide 1 y) y 20 | 9. divide (divide (divide (divide 1 x) y) x) x = divide (divide (divide (divide 1 x) x) x) y 21 | 10. divide (divide (divide (divide 1 x) x) y) y = divide (divide (divide (divide 1 y) y) x) x 22 | 11. divide (divide (divide (divide 1 x) x) x) x = divide (divide 1 x) x 23 | 12. divide (divide (divide (divide (nonZeroInt x) y) y) x) y = divide (divide (divide 1 y) y) y 24 | 25 | -------------------------------------------------------------------------------- /examples/tests/Sorted-typeclass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, RankNTypes, ConstraintKinds #-} 2 | -- Sorting and sorted lists. 3 | -- Illustrates testing of conditional laws. 4 | import QuickSpec 5 | import Data.List 6 | 7 | sorted :: Ord a => [a] -> Bool 8 | sorted [] = True 9 | sorted [_] = True 10 | sorted (x:y:xs) = x <= y && sorted (y:xs) 11 | 12 | lift :: (c => a) -> Dict c -> a 13 | lift f Dict = f 14 | 15 | main = quickSpec [ 16 | con "[]" ([] :: [A]), 17 | con ":" ((:) :: A -> [A] -> [A]), 18 | con "sort" (lift sort :: Dict (Ord A) -> [A] -> [A]), 19 | con "insert" (lift insert :: Dict (Ord A) -> A -> [A] -> [A]), 20 | predicate "sorted" (lift sorted :: Dict (Ord A) -> [A] -> Bool) ] 21 | -------------------------------------------------------------------------------- /examples/tests/Sorted-typeclass.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | [] :: [a] 3 | (:) :: a -> [a] -> [a] 4 | sort :: Ord a => [a] -> [a] 5 | insert :: Ord a => a -> [a] -> [a] 6 | sorted :: Ord a => [a] -> Bool 7 | 8 | == Laws == 9 | 1. sorted [] 10 | 2. sort [] = [] 11 | 3. sorted xs => sort xs = xs 12 | 4. insert x [] = x : [] 13 | 5. sorted (sort xs) 14 | 6. sorted (insert x xs) = sorted xs 15 | 7. sort (insert x xs) = sort (x : xs) 16 | 8. insert x (sort xs) = sort (x : xs) 17 | 9. insert x (x : xs) = x : (x : xs) 18 | 10. insert x (insert y xs) = insert y (insert x xs) 19 | 11. sorted (x : insert x xs) = sorted (x : xs) 20 | 21 | -------------------------------------------------------------------------------- /examples/tests/Sorted.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | [] :: [a] 3 | (:) :: a -> [a] -> [a] 4 | 5 | == Functions == 6 | sort :: [Int] -> [Int] 7 | insert :: Int -> [Int] -> [Int] 8 | sorted :: [Int] -> Bool 9 | 10 | == Laws == 11 | 1. sorted [] 12 | 2. sort [] = [] 13 | 3. sorted xs => sort xs = xs 14 | 4. insert x [] = x : [] 15 | 5. sorted (sort xs) 16 | 6. sorted (insert x xs) = sorted xs 17 | 7. sort (insert x xs) = sort (x : xs) 18 | 8. insert x (sort xs) = sort (x : xs) 19 | 9. insert x (x : xs) = x : (x : xs) 20 | 10. insert x (insert y xs) = insert y (insert x xs) 21 | 11. sorted (x : insert x xs) = sorted (x : xs) 22 | 23 | -------------------------------------------------------------------------------- /examples/tests/TinyWM.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (||) :: Bool -> Bool -> Bool 3 | (&&) :: Bool -> Bool -> Bool 4 | not :: Bool -> Bool 5 | True :: Bool 6 | False :: Bool 7 | 0 :: Int 8 | 1 :: Int 9 | [] :: [a] 10 | (:) :: a -> [a] -> [a] 11 | (++) :: [a] -> [a] -> [a] 12 | 0 :: Natural 13 | 1 :: Natural 14 | (+) :: Natural -> Natural -> Natural 15 | 16 | == Functions == 17 | LT :: Ordering 18 | GT :: Ordering 19 | EQ :: Ordering 20 | empty :: Natural -> StackSet OrdA 21 | view :: Natural -> StackSet OrdA -> StackSet OrdA 22 | peek :: StackSet OrdA -> OrdA 23 | rotate :: Ordering -> StackSet OrdA -> StackSet OrdA 24 | push :: OrdA -> StackSet OrdA -> StackSet OrdA 25 | shift :: Natural -> StackSet OrdA -> StackSet OrdA 26 | insert :: OrdA -> Natural -> StackSet OrdA -> StackSet OrdA 27 | delete :: OrdA -> StackSet OrdA -> StackSet OrdA 28 | current :: StackSet OrdA -> Natural 29 | index :: Natural -> StackSet OrdA -> [OrdA] 30 | 31 | == Laws == 32 | 1. rotate EQ s = s 33 | 2. current (empty x) = 0 34 | 3. current (shift x s) = current s 35 | 4. current (rotate o s) = current s 36 | 5. current (delete x s) = current s 37 | 6. current (push x s) = current s 38 | 7. peek (push x s) = x 39 | 8. shift (current s) s = s 40 | 9. view (current s) s = s 41 | 10. current (view 0 s) = 0 42 | 11. shift x (empty 1) = empty 1 43 | 12. view x (empty 1) = empty 1 44 | 13. rotate o (empty 1) = empty 1 45 | 14. delete x (empty 1) = empty 1 46 | 15. index 0 (empty 1) = [] 47 | 16. current (insert x y s) = current s 48 | 17. insert x y s = shift y (push x s) 49 | 18. view x (view x s) = view x s 50 | 19. rotate o (rotate o' s) = rotate o' (rotate o s) 51 | 20. delete x (view y s) = view y (delete x s) 52 | 21. delete x (delete y s) = delete y (delete x s) 53 | 22. delete x (delete x s) = delete x s 54 | 23. delete x (push x s) = delete x s 55 | 24. push x (delete x s) = push x s 56 | 25. index 0 (view x s) = index 0 s 57 | 26. view 0 (view x s) = view 0 s 58 | 27. view 1 (view x s) = view 1 s 59 | 28. rotate GT (rotate LT s) = s 60 | 29. insert x 1 (empty 1) = empty 1 61 | 30. delete x (insert x y s) = delete x s 62 | 31. view x (insert y z s) = insert y z (view x s) 63 | 32. view (current s) (view x s) = s 64 | 33. index 0 (insert x 1 s) = index 0 (delete x s) 65 | 34. current (view x (shift y s)) = current (view x s) 66 | 35. current (view x (rotate o s)) = current (view x s) 67 | 36. index x (empty (x + 1)) = [] 68 | 37. shift x (empty (y + 1)) = empty (y + 1) 69 | 38. rotate o (empty (x + 1)) = empty (x + 1) 70 | 39. rotate o (push x (empty 1)) = push x (empty 1) 71 | 40. delete x (empty (y + 1)) = empty (y + 1) 72 | 41. index 0 (empty (x + 1)) = [] 73 | 42. index 0 (push x (empty 1)) = x : [] 74 | 43. insert x (y + y) (empty 1) = insert x y (empty 1) 75 | 44. insert x (y + 1) (empty 1) = empty 1 76 | 45. view x (shift y (view x s)) = shift y (view x s) 77 | 46. view x (view y (view x s)) = view x (view y s) 78 | 47. view x (view (x + y) s) = view x s 79 | 48. view x (rotate o (view x s)) = rotate o (view x s) 80 | 49. view x (push y (view x s)) = push y (view x s) 81 | 50. delete x (shift y (delete x s)) = shift y (delete x s) 82 | 51. delete x (rotate o (delete x s)) = rotate o (delete x s) 83 | 52. delete x (push y (delete x s)) = delete x (push y s) 84 | 53. index 0 (shift (x + x) s) = index 0 (shift x s) 85 | 54. shift x (insert y z (empty 1)) = insert y (x + z) (empty 1) 86 | 55. rotate o (insert x y (empty 1)) = insert x y (empty 1) 87 | 56. x : index 0 (delete x s) = index 0 (insert x 0 s) 88 | 57. delete x (rotate GT (push x s)) = delete x s 89 | 58. delete x (rotate LT (push x s)) = rotate LT (delete x s) 90 | 59. index 0 (shift (x + 1) s) = index 0 (shift 1 s) 91 | 60. shift 1 (shift x (view 1 s)) = shift x (shift 1 (view 1 s)) 92 | 61. insert x 1 (push y (empty 1)) = delete x (push y (empty 1)) 93 | 62. current (view x (empty (x + 1))) = x 94 | 63. current (view (current (view 1 s)) s2) = current (view (current (view 1 s2)) s) 95 | 96 | -------------------------------------------------------------------------------- /examples/tests/TypeClass.hs: -------------------------------------------------------------------------------- 1 | -- A simple example testing arithmetic functions. 2 | {-# LANGUAGE TypeOperators 3 | , TypeApplications 4 | #-} 5 | import QuickSpec 6 | 7 | -- Integers 8 | main = quickSpec [ con "0" (liftC 0 :: Num A ==> A) 9 | , con "1" (liftC 1 :: Num A ==> A) 10 | , con "+" (liftC (+) :: Num A ==> (A -> A -> A)) 11 | , con "*" (liftC (*) :: Num A ==> (A -> A -> A)) 12 | , instanceOf @(Num Float) 13 | , monoType (Proxy :: Proxy Float) 14 | , withInferInstanceTypes 15 | ] 16 | -------------------------------------------------------------------------------- /examples/tests/TypeClass.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | 0 :: Num a => a 3 | 1 :: Num a => a 4 | (+) :: Num a => a -> a -> a 5 | (*) :: Num a => a -> a -> a 6 | 7 | == Laws == 8 | 1. x * y = y * x 9 | 2. x + y = y + x 10 | 3. x * 0 = 0 11 | 4. x * 1 = x 12 | 5. x + 0 = x 13 | 6. x * (y + y) = y * (x + x) 14 | 7. (x * y) + (x * y) = x * (y + y) 15 | 8. (x + x) + (y + y) = (x + y) * (1 + 1) 16 | 9. x + (x + (x + x)) = (x + x) + (x + x) 17 | 10. 1 + (x + (x + 1)) = (x + x) + (1 + 1) 18 | 11. 1 + (1 + (x + y)) = (x + y) + (1 + 1) 19 | 12. x * (1 + (1 + 1)) = x + (x + x) 20 | 21 | -------------------------------------------------------------------------------- /examples/tests/Zip.output: -------------------------------------------------------------------------------- 1 | == Functions == 2 | (++) :: [Int] -> [Int] -> [Int] 3 | zip :: [Int] -> [Int] -> [(Int, Int)] 4 | eqLen :: [Int] -> [Int] -> Bool 5 | 6 | == Laws == 7 | 1. eqLen xs ys = eqLen ys xs 8 | 2. eqLen xs xs 9 | 3. eqLen zs ys => eqLen xs ys = eqLen xs zs 10 | 4. eqLen xs (ys ++ zs) = eqLen xs (zs ++ ys) 11 | 5. eqLen xs (xs ++ ys) = eqLen zs (zs ++ ys) 12 | 6. (xs ++ ys) ++ zs = xs ++ (ys ++ zs) 13 | 7. zip xs (xs ++ ys) = zip xs xs 14 | 8. zip (xs ++ ys) xs = zip xs xs 15 | 9. eqLen ws zs => eqLen xs (ys ++ zs) = eqLen xs (ys ++ ws) 16 | 10. eqLen xs ys => zip xs (ys ++ zs) = zip xs ys 17 | 11. eqLen xs zs => zip (xs ++ ys) zs = zip xs zs 18 | 12. eqLen (xs ++ ys) (xs ++ zs) = eqLen ys zs 19 | 13. eqLen (xs ++ xs) (ys ++ ys) = eqLen xs ys 20 | 14. eqLen xs (ys ++ (zs ++ ws)) = eqLen xs (ys ++ (ws ++ zs)) 21 | 15. zip xs (ys ++ (xs ++ zs)) = zip xs (ys ++ xs) 22 | 16. zip (xs ++ (ys ++ zs)) ys = zip (xs ++ ys) ys 23 | 17. eqLen xs zs => zip xs (ys ++ (zs ++ ws)) = zip xs (ys ++ zs) 24 | 18. eqLen ys ws => zip (xs ++ (ys ++ zs)) ws = zip (xs ++ ys) ws 25 | 26 | -------------------------------------------------------------------------------- /examples/tests/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | exitcode=0 3 | GHC=${GHC=ghc} 4 | cd $(dirname $0)/.. 5 | for i in ./*.hs tests/*.hs; do 6 | prog=${i/.hs/} 7 | out=tests/$(basename $prog).output 8 | if [ -f $out ]; then 9 | $GHC --make -O $i || exitcode=1 10 | echo $prog 11 | tmp=$(mktemp) 12 | QUICKCHECK_SEED=1234 $prog > $tmp 2>/dev/null || exitcode=1 13 | diff -u $out $tmp || exitcode=1 14 | fi 15 | done 16 | exit $exitcode 17 | -------------------------------------------------------------------------------- /examples/tests/update: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | GHC=${GHC=ghc} 4 | for i in $*; do 5 | $GHC --make -O $i 6 | prog=${i/.hs/} 7 | out=$(dirname $0)/$(basename $prog).output 8 | QUICKCHECK_SEED=1234 $prog > $out 9 | done 10 | -------------------------------------------------------------------------------- /examples/weird/ConditionalsPruning.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | import Control.Monad 3 | import Test.QuickCheck 4 | import QuickSpec 5 | import Data.Dynamic 6 | 7 | sig = 8 | signature { 9 | maxTermSize = Just 4, 10 | maxPruningSize = Just 10, 11 | constants = [ 12 | constant "poh" foo, 13 | constant "bar" bar, 14 | constant "baz" baz 15 | ], 16 | predicates = [ 17 | predicate "p" p 18 | ] 19 | } 20 | 21 | foo :: Int -> Int 22 | foo 0 = bar 23 | foo 1 = bar 24 | foo x = bar + x 25 | 26 | bar :: Int 27 | bar = -10 28 | 29 | baz :: Int -> Int -> Int 30 | baz _ _ = 1 31 | 32 | p :: Int -> Bool 33 | p x = (x == 0) || (x == 1) 34 | 35 | main = quickSpec sig 36 | -------------------------------------------------------------------------------- /examples/weird/DrawGeometry.hs: -------------------------------------------------------------------------------- 1 | import Prelude hiding (cycle, flip) 2 | import qualified Diagrams.Prelude as D 3 | import qualified Diagrams.Backend.SVG as D 4 | 5 | type Drawing = D.Diagram D.SVG D.R2 6 | 7 | size :: Double 8 | size = 600 9 | 10 | stretch :: Drawing -> Drawing 11 | stretch x = D.scaleX (1/D.width x) (D.scaleY (1/D.height x) x) 12 | 13 | prim :: Drawing -> Drawing 14 | prim x = D.centerXY (x D.# D.sized (D.Dims size size)) `D.atop` D.phantom (D.square size :: Drawing) 15 | 16 | image :: FilePath -> IO Drawing 17 | image file = do 18 | res <- D.loadImageEmb file 19 | case res of 20 | Left err -> error (show err) 21 | Right img -> return (prim (D.image img)) 22 | 23 | over, above, above', beside :: Drawing -> Drawing -> Drawing 24 | beside x y = prim (D.scaleX (1/2) x D.||| D.scaleX (1/2) y) 25 | above x y = prim (D.scaleY (1/2) x D.=== D.scaleY (1/2) y) 26 | above' x y = prim (D.scaleY (1/2) y D.=== D.scaleY (1/2) x) 27 | over x y = D.atop x y 28 | 29 | rot :: Drawing -> Drawing 30 | rot = D.rotate (90 D.@@ D.deg) 31 | 32 | flip :: Drawing -> Drawing 33 | flip = D.reflectX 34 | 35 | quartet, quartet' :: Drawing -> Drawing -> Drawing -> Drawing -> Drawing 36 | quartet a b c d = (a `beside` b) `above` (c `beside` d) 37 | quartet' a b c d = (a `beside` b) `above'` (c `beside` d) 38 | 39 | cycle, cycle', anticycle :: Drawing -> Drawing 40 | cycle x = quartet x (rot (rot (rot x))) (rot x) (rot (rot x)) 41 | cycle' x = quartet' x (rot (rot (rot x))) (rot x) (rot (rot x)) 42 | anticycle x = quartet x (rot x) (rot (rot (rot x))) (rot (rot x)) 43 | 44 | render file dia = D.renderSVG file (D.Width size) dia 45 | 46 | main = do 47 | img <- image "whatever.png" 48 | render "cycle-whatever.svg" (cycle' (cycle' img)) 49 | -------------------------------------------------------------------------------- /examples/weird/Exp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} 2 | {-# LANGUAGE EmptyDataDecls, RankNTypes, ScopedTypeVariables #-} 3 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeOperators, PolyKinds #-} 6 | module Main where 7 | import Prelude hiding (sequence) 8 | import Data.Typeable 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Gen.Unsafe 11 | import GHC.Generics 12 | import GenericStuff 13 | import QuickSpec hiding (Observe, observe) 14 | import qualified QuickSpec as QS 15 | 16 | deriving instance Typeable Observe 17 | deriving instance Typeable Typeable 18 | 19 | data Expr a b = Cex a 20 | | Vex b 21 | | Bex (a -> a -> a) (Expr a b) (Expr a b) 22 | deriving (Typeable, Generic) 23 | 24 | instance (Arbitrary a, Typeable a, Arbitrary b, CoArbitrary b, Typeable b) => 25 | Arbitrary (Expr b a) where 26 | arbitrary = genericArbitrary 27 | 28 | instance (CoArbitrary a, Arbitrary b, CoArbitrary b) => 29 | CoArbitrary (Expr b a) where 30 | coarbitrary = genericCoarbitrary 31 | 32 | instance (Arbitrary b, Observe a, Observe b) => 33 | Observe (Expr b a) where 34 | observe = genericObserve 35 | 36 | data Instruction a b = 37 | Const a 38 | | Load b 39 | | Apply (a -> a -> a) 40 | deriving (Typeable, Generic) 41 | 42 | instance (Arbitrary a, Typeable a, Arbitrary b, CoArbitrary b, Typeable b) => 43 | Arbitrary (Instruction b a) where 44 | arbitrary = 45 | oneof [fmap Const arbitrary, fmap Load arbitrary, fmap Apply arbitrary] 46 | 47 | instance (CoArbitrary a, Arbitrary b, CoArbitrary b) => 48 | CoArbitrary (Instruction b a) where 49 | coarbitrary = genericCoarbitrary 50 | 51 | instance (Observe a, Arbitrary b, Observe b) => 52 | Observe (Instruction b a) where 53 | observe = genericObserve 54 | 55 | exec :: (v -> c) -> [Instruction c v] -> [c] -> Maybe [c] 56 | exec env [] stack = Just stack 57 | exec env (Const c:p) stack = exec env p (c:stack) 58 | exec env (Load v:p) stack = exec env p (env v:stack) 59 | exec env (Apply b:p) (x:y:stack) = exec env p (b x y:stack) 60 | exec _ _ _ = Nothing 61 | 62 | value :: (v -> c) -> Expr c v -> c 63 | value env (Cex c) = c 64 | value env (Vex v) = env v 65 | value env (Bex b e1 e2) = b (value env e1) (value env e2) 66 | 67 | compile :: Expr v c -> [Instruction v c] 68 | compile (Cex c) = [Const c] 69 | compile (Vex v) = [Load v] 70 | compile (Bex b e1 e2) = compile e2 ++ compile e1 ++ [Apply b] 71 | 72 | bg = 73 | signature { 74 | constants = [ 75 | constant ":" ((:) :: A -> [A] -> [A]), 76 | constant "[]" ([] :: [A]), 77 | constant "Just" (Just :: A -> Maybe A), 78 | constant "++" ((++) :: [A] -> [A] -> [A]) ]} 79 | 80 | main = 81 | quickSpecWithBackground bg signature { 82 | instances = [ 83 | names (NamesFor ["i"] :: NamesFor (Instruction A B)), 84 | names (NamesFor ["e"] :: NamesFor (Expr A B)), 85 | names (NamesFor ["env"] :: NamesFor (A -> B)), 86 | makeInstance (\(Dict :: Dict (Observe A)) -> QS.Observe Dict (observe :: A -> Gen Observation)), 87 | inst5 (Sub Dict :: (Arbitrary A, Typeable A, Arbitrary B, CoArbitrary B, Typeable B) :- Arbitrary (Expr B A)), 88 | inst5 (Sub Dict :: (Arbitrary A, Typeable A, Arbitrary B, CoArbitrary B, Typeable B) :- Arbitrary (Instruction B A)), 89 | inst3 (Sub Dict :: (CoArbitrary A, Arbitrary B, CoArbitrary B) :- CoArbitrary (Expr B A)), 90 | inst3 (Sub Dict :: (CoArbitrary A, Arbitrary B, CoArbitrary B) :- CoArbitrary (Instruction B A)), 91 | inst3 (Sub Dict :: (Arbitrary B, Observe A, Observe B) :- Observe (Expr B A)), 92 | inst3 (Sub Dict :: (Arbitrary B, Observe A, Observe B) :- Observe (Instruction B A)), 93 | inst (Sub Dict :: () :- Typeable Int), 94 | inst (Sub Dict :: () :- Observe Int) ], 95 | constants = [ 96 | constant "compile" (compile :: Expr A B -> [Instruction A B]), 97 | constant "value" (value :: (A -> B) -> Expr B A -> B), 98 | constant "exec" (exec :: (A -> B) -> [Instruction B A] -> [B] -> Maybe [B]) ]} 99 | -------------------------------------------------------------------------------- /examples/weird/Gyrogroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} 2 | import QuickSpec 3 | import Test.QuickCheck 4 | import System.Random 5 | import Data.Monoid 6 | 7 | class Group a where 8 | ident :: a 9 | op :: a -> a -> a 10 | inv :: a -> a 11 | gyr :: a -> a -> a -> a 12 | 13 | newtype Gyrogroup = G Int deriving (Eq, Ord, Typeable, CoArbitrary, Enum, Num, Random, Real, Integral, Show) 14 | 15 | instance Arbitrary Gyrogroup where 16 | arbitrary = choose (1, 16) 17 | 18 | gident :: Gyrogroup 19 | gident = 1 20 | 21 | b = (,) 22 | 23 | f :: Int -> Int -> (Int, Int) 24 | f 1 1 = b 1 2 25 | f 1 2 = b 3 4 26 | f 1 3 = b 5 6 27 | f 1 4 = b 7 8 28 | f 1 5 = b 9 10 29 | f 1 6 = b 11 12 30 | f 1 7 = b 13 14 31 | f 1 8 = b 15 16 32 | f 2 1 = b 3 4 33 | f 2 2 = b 2 1 34 | f 2 3 = b 7 8 35 | f 2 4 = b 6 5 36 | f 2 5 = b 12 11 37 | f 2 6 = b 9 10 38 | f 2 7 = b 16 15 39 | f 2 8 = b 13 14 40 | f 3 1 = b 5 6 41 | f 3 2 = b 7 8 42 | f 3 3 = b 4 3 43 | f 3 4 = b 1 2 44 | f 3 5 = b 16 15 45 | f 3 6 = b 13 14 46 | f 3 7 = b 10 9 47 | f 3 8 = b 12 11 48 | f 4 1 = b 7 8 49 | f 4 2 = b 6 5 50 | f 4 3 = b 1 2 51 | f 4 4 = b 3 4 52 | f 4 5 = b 14 13 53 | f 4 6 = b 16 15 54 | f 4 7 = b 11 12 55 | f 4 8 = b 10 9 56 | f 5 1 = b 9 10 57 | f 5 2 = b 11 12 58 | f 5 3 = b 13 14 59 | f 5 4 = b 15 16 60 | f 5 5 = b 1 2 61 | f 5 6 = b 3 4 62 | f 5 7 = b 5 6 63 | f 5 8 = b 7 8 64 | f 6 1 = b 11 12 65 | f 6 2 = b 10 9 66 | f 6 3 = b 15 16 67 | f 6 4 = b 14 13 68 | f 6 5 = b 4 3 69 | f 6 6 = b 1 2 70 | f 6 7 = b 8 7 71 | f 6 8 = b 5 6 72 | f 7 1 = b 13 14 73 | f 7 2 = b 15 16 74 | f 7 3 = b 12 11 75 | f 7 4 = b 9 10 76 | f 7 5 = b 7 8 77 | f 7 6 = b 6 5 78 | f 7 7 = b 1 2 79 | f 7 8 = b 3 4 80 | f 8 1 = b 15 16 81 | f 8 2 = b 14 13 82 | f 8 3 = b 9 10 83 | f 8 4 = b 11 12 84 | f 8 5 = b 5 6 85 | f 8 6 = b 7 8 86 | f 8 7 = b 4 3 87 | f 8 8 = b 1 2 88 | 89 | gop :: Gyrogroup -> Gyrogroup -> Gyrogroup 90 | gop (G x) (G y) 91 | | x `mod` 2 == y `mod` 2 = G a 92 | | otherwise = G b 93 | where 94 | (a, b) = f ((x+1) `div` 2) ((y+1) `div` 2) 95 | 96 | ginv :: Gyrogroup -> Gyrogroup 97 | ginv x = head [ y | y <- [1..16], op y x == ident ] 98 | 99 | ggyr :: Gyrogroup -> Gyrogroup -> Gyrogroup -> Gyrogroup 100 | ggyr x y 101 | | x >= 5 && x <= 8 && y >= 9 = a 102 | | y >= 5 && y <= 8 && x >= 9 = a 103 | | x >= 9 && x <= 12 && y >= 13 = a 104 | | y >= 9 && y <= 12 && x >= 13 = a 105 | | otherwise = id 106 | where 107 | a z 108 | | z <= 8 = z 109 | | even z = z-1 110 | | otherwise = z+1 111 | 112 | instance Group Gyrogroup where 113 | ident = gident 114 | op = gop 115 | inv = ginv 116 | gyr = ggyr 117 | 118 | instance Group Int where 119 | ident = 0 120 | op = (+) 121 | inv = negate 122 | gyr _ _ = id 123 | 124 | instance (Group a, Group b) => Group (a, b) where 125 | ident = (ident, ident) 126 | op (x, x') (y, y') = (op x y, op x' y') 127 | inv (x, y) = (inv x, inv y) 128 | gyr (x, x') (y, y') (z, z') = (gyr x y z, gyr x' y' z') 129 | 130 | props :: (Eq a, Group a) => a -> a -> a -> [Bool] 131 | props a b c = [ 132 | ident `op` a == a, 133 | a `op` ident == a, 134 | inv a `op` a == ident, 135 | a `op` (b `op` c) == (a `op` b) `op` gyr a b c, 136 | (a `op` b) `op` c == a `op` (b `op` gyr b a c), 137 | gyr a b c == gyr (a `op` b) b c, 138 | gyr a b c == gyr a (b `op` a) c, 139 | inv (a `op` b) == gyr a b (inv b `op` inv a)] 140 | 141 | type It = (Gyrogroup, Int) 142 | 143 | sig0 = 144 | signature { 145 | instances = [baseType (undefined :: It)], 146 | maxTermSize = Just 8, 147 | maxTests = Just 500 } 148 | 149 | sig1 = 150 | sig0 { 151 | constants = [ 152 | constant "0" (ident :: It), 153 | constant "+" (op :: It -> It -> It) ]} 154 | 155 | sig2 = 156 | sig0 { 157 | constants = [ 158 | constant "-" (inv :: It -> It) ]} 159 | 160 | sig3 = 161 | sig0 { 162 | constants = [ 163 | (constant "gyr" (gyr :: It -> It -> It -> It)) ]} 164 | 165 | sig4 = 166 | sig0 { 167 | constants = [ 168 | constant "[+]" (\a b -> a `op` gyr a (inv b) b :: It) ]} 169 | 170 | main = do 171 | thy1 <- quickSpec sig1 172 | thy2 <- quickSpec (thy1 `mappend` sig2) 173 | thy3 <- quickSpec (thy2 `mappend` sig3) 174 | thy4 <- quickSpec (thy3 `mappend` sig4) 175 | return () 176 | -------------------------------------------------------------------------------- /examples/weird/Ords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} 2 | import Prelude hiding (exp) 3 | import Test.QuickCheck 4 | import Data.Ord 5 | import QuickSpec 6 | import Twee.Pretty 7 | 8 | newtype Nat = Nat Int deriving (Eq, Ord, Num, Enum, CoArbitrary) 9 | 10 | instance Arbitrary Nat where 11 | arbitrary = fmap Nat (fmap abs arbitrary) 12 | 13 | data Ordinal = Zero | Succ Ordinal | Lim (Nat -> Ordinal) deriving Typeable 14 | 15 | instance Arbitrary Ordinal where 16 | arbitrary = 17 | oneof (fmap Lim arbitrary:map (return . toOrdinal) [0..3]) 18 | where 19 | toOrdinal 0 = Zero 20 | toOrdinal n = Succ (toOrdinal (n-1)) 21 | 22 | instance CoArbitrary Ordinal where 23 | coarbitrary Zero = variant 0 24 | coarbitrary (Succ o) = variant 1 . coarbitrary o 25 | coarbitrary (Lim h) = variant 2 . coarbitrary h 26 | 27 | instance Eq Ordinal where 28 | x == y = compare x y == EQ 29 | 30 | instance Ord Ordinal where 31 | compare = comparing toNat 32 | where 33 | toNat Zero = 0 34 | toNat (Succ x) = succ (toNat x) 35 | toNat (Lim f) = maximum (map (toNat' . f) [0..10]) 36 | toNat' Zero = 0 37 | toNat' (Succ x) = succ (toNat' x) 38 | toNat' (Lim f) = 10000 39 | {- compare Zero Zero = EQ 40 | compare Zero _ = LT 41 | compare (Succ x) Zero = GT 42 | compare (Succ x) (Succ y) = compare x y 43 | compare (Succ x) _ = LT 44 | compare (Lim _) Zero = GT 45 | compare (Lim _) (Succ _) = GT 46 | compare (Lim f) (Lim g) = compare (f 3) (g 3)-} 47 | 48 | plus :: Ordinal -> Ordinal -> Ordinal 49 | plus m Zero = m 50 | plus m (Succ n) = Succ (plus m n) 51 | plus m (Lim f) = Lim (\n -> plus m (f n)) 52 | 53 | times :: Ordinal -> Ordinal -> Ordinal 54 | times m Zero = Zero 55 | times m (Succ n) = plus (times m n) m 56 | times m (Lim f) = Lim (\n -> times m (f n)) 57 | 58 | exp :: Ordinal -> Ordinal -> Ordinal 59 | exp m Zero = Succ Zero 60 | exp m (Succ n) = times (exp m n) m 61 | exp m (Lim f) = Lim (\n -> exp m (f n)) 62 | 63 | sig = 64 | signature { 65 | constants = [ 66 | constant "0" Zero, 67 | (constant "s" Succ) { conStyle = uncurried }, 68 | constant "+" plus, 69 | constant "*" times ], 70 | instances = [ 71 | baseType (undefined :: Ordinal) ]} 72 | 73 | main = quickSpec sig 74 | -------------------------------------------------------------------------------- /examples/weird/Table9Point1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | import QuickSpec 3 | import Test.QuickCheck 4 | 5 | data Table9Point1 = I | A | B | C | D deriving (Eq, Ord, Show, Typeable) 6 | 7 | instance Arbitrary Table9Point1 where 8 | arbitrary = elements [I, A, B, C, D] 9 | 10 | instance CoArbitrary Table9Point1 where 11 | coarbitrary = coarbitraryShow 12 | 13 | times :: Table9Point1 -> Table9Point1 -> Table9Point1 14 | times I I = I 15 | times I A = A 16 | times I B = B 17 | times I C = C 18 | times I D = D 19 | times A I = A 20 | times A A = A 21 | times A B = B 22 | times A C = D 23 | times A D = D 24 | times B I = B 25 | times B A = B 26 | times B B = D 27 | times B C = A 28 | times B D = A 29 | times C I = C 30 | times C A = D 31 | times C B = A 32 | times C C = B 33 | times C D = B 34 | times D I = D 35 | times D A = D 36 | times D B = A 37 | times D C = B 38 | times D D = B 39 | 40 | sig = 41 | signature { 42 | constants = [ 43 | constant "times" times, 44 | constant "i" I, 45 | constant "a" A, 46 | constant "b" B, 47 | constant "c" C, 48 | constant "d" D ], 49 | instances = [ 50 | baseType (undefined :: Table9Point1)]} 51 | 52 | main = quickSpec sig 53 | -------------------------------------------------------------------------------- /examples/weird/Zipper.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | import Test.QuickCheck 3 | import Prelude hiding (Left, Right) 4 | import Control.Monad 5 | import Data.Typeable 6 | import QuickSpec 7 | 8 | data Tree = Nil | Cons Tree Tree deriving (Eq, Ord, Typeable) 9 | data Path = Top | Left Path Tree | Right Tree Path deriving (Eq, Ord) 10 | data Zipper = Zipper Tree Path deriving (Eq, Ord, Typeable) 11 | 12 | instance Arbitrary Zipper where 13 | arbitrary = liftM2 Zipper arbitrary arbitrary 14 | instance CoArbitrary Zipper where 15 | coarbitrary (Zipper t p) = coarbitrary (t,p) 16 | instance Arbitrary Tree where 17 | arbitrary = 18 | sized $ \n -> resize (n `div` 2) $ 19 | oneof $ 20 | [ return Nil ] ++ 21 | [ liftM2 Cons arbitrary arbitrary | n > 0 ] 22 | instance CoArbitrary Tree where 23 | coarbitrary Nil = variant 0 24 | coarbitrary (Cons x y) = variant 1 . coarbitrary (x,y) 25 | instance Arbitrary Path where 26 | arbitrary = 27 | sized $ \n -> resize (n `div` 2) $ 28 | oneof $ 29 | [ return Top ] ++ 30 | [ liftM2 Left arbitrary arbitrary | n > 0 ] ++ 31 | [ liftM2 Right arbitrary arbitrary | n > 0 ] 32 | instance CoArbitrary Path where 33 | coarbitrary Top = variant 0 34 | coarbitrary (Left p t) = variant 1 . coarbitrary (p,t) 35 | coarbitrary (Right p t) = variant 2 . coarbitrary (p,t) 36 | 37 | change :: Maybe Zipper -> Maybe Tree -> Maybe Zipper 38 | change (Just (Zipper _ p)) (Just t) = Just (Zipper t p) 39 | change _ _ = Nothing 40 | 41 | upLeft, upRight, up, left, right :: Maybe Zipper -> Maybe Zipper 42 | upLeft (Just (Zipper t (Right left father))) = Just (Zipper left (Left father t)) 43 | upLeft _ = Nothing 44 | upRight (Just (Zipper t (Left father right))) = Just (Zipper right (Right t father)) 45 | upRight _ = Nothing 46 | up (Just (Zipper t (Left father right))) = Just (Zipper (Cons t right) father) 47 | up _ = Nothing 48 | left (Just (Zipper (Cons left right) p)) = Just (Zipper left (Left p right)) 49 | left _ = Nothing 50 | right (Just (Zipper (Cons left right) p)) = Just (Zipper right (Right right p)) 51 | right _ = Nothing 52 | 53 | fromZipper :: Maybe Zipper -> Maybe Tree 54 | fromZipper (Just (Zipper t p)) = Just (apply t p) 55 | where 56 | apply t Top = t 57 | apply t (Left p u) = apply (Cons t u) p 58 | apply t (Right u p) = apply (Cons u t) p 59 | fromZipper _ = Nothing 60 | 61 | toZipper :: Maybe Tree -> Maybe Zipper 62 | toZipper (Just t) = Just (Zipper t Top) 63 | toZipper _ = Nothing 64 | 65 | sig = 66 | signature { 67 | constants = [ 68 | constant "nothing" (Nothing :: Maybe A), 69 | constant "nil" Nil, 70 | constant "cons" Cons, 71 | constant "change" change, 72 | constant "up" up, 73 | constant "upLeft" upLeft, 74 | constant "upRight" upRight, 75 | constant "left" left, 76 | constant "right" right, 77 | constant "fromZipper" fromZipper, 78 | constant "toZipper" toZipper ], 79 | instances = [ 80 | baseType (undefined :: Zipper), 81 | baseType (undefined :: Tree) ]} 82 | 83 | main = quickSpec sig 84 | -------------------------------------------------------------------------------- /notes: -------------------------------------------------------------------------------- 1 | does regenerlise need to worry about restricting occurrences of the 2 | same var to have the same type? now we have the invariant that each 3 | var has a unique type 4 | 5 | NOTE: 6 | schema layer should somehow be the same, whether we're discovering 7 | equations or something else. maybe this means splitting lower layers 8 | into "conjecture-by-testing" and "discard-by-pruning" parts? 9 | 10 | Things which should be expressed as single modules or whatever: 11 | * term-based exploration 12 | * schema-based exploration 13 | - instantiate schemas 14 | - possibly do smart instantiation 15 | * polymorphism 16 | - regeneralise monomorphic laws 17 | - generate mgus of terms of unifiable types 18 | - (do this at the term or the schema level?) 19 | * the term generation loop 20 | * conditional laws 21 | - a post-filter on discovered laws to instantiate conditional axioms 22 | * quickcheck 23 | * exception catching? 24 | * higher-order functions and partial application? 25 | - generate partially-applied terms? 26 | - what to do about type universe for polymorphism? 27 | - eta-expand discovered laws 28 | - maybe can incrementally expand type universe as new functions appear 29 | * delaying non-orientable laws 30 | - generate terms as usual 31 | - filter equations that come out 32 | - when we spot a bigger term, stop delaying 33 | * lambda terms? 34 | * timeouts? in general, "opting out" of a particular test case? 35 | [this term is not defined on this test case, e.g. partial models] 36 | * discovering inconsistent laws 37 | (when two representative terms get the same normal form) 38 | 39 | Pipeline: in goes term ---> out comes set of laws - this is compatible with schemas going in 40 | Term generation loop: maintain set of terms, keep them normalised wrt rules rather than remembering which ones are representatives? 41 | 42 | Delaying is interesting. Delaying says: 43 | * I generate a term 44 | * Out comes a law 45 | * Oops I shouldn't have generated this term, wait a bit 46 | * Generate it again later 47 | It should perhaps be part of the main term generation loop? 48 | 49 | Schema generation maintains lots of different little test sets. 50 | 51 | Bug: discover elem x xs = any (== x) xs 52 | 53 | From TODO file: 54 | Instead of conGeneralValue/regeneralise nonsense, have a type 55 | constructor "Mono a" which wraps its argument while having its Typed 56 | instance unify all types. 57 | 58 | Model delaying as a function taking list of terms and only delaying 59 | inside that list 60 | -------------------------------------------------------------------------------- /quickspec.cabal: -------------------------------------------------------------------------------- 1 | Name: quickspec 2 | Version: 2.2 3 | Cabal-version: >= 1.10 4 | Build-type: Simple 5 | 6 | Homepage: https://github.com/nick8325/quickspec 7 | Author: Nick Smallbone 8 | Maintainer: nicsma@chalmers.se 9 | 10 | License: BSD3 11 | License-file: LICENSE 12 | Copyright: 2009-2019 Nick Smallbone 13 | 14 | Category: Testing 15 | 16 | Synopsis: Equational laws for free! 17 | Description: 18 | QuickSpec takes your Haskell code and, as if by magic, discovers laws 19 | about it. You give QuickSpec a collection of Haskell functions; 20 | QuickSpec tests your functions with QuickCheck and prints out laws which 21 | seem to hold. 22 | . 23 | For example, give QuickSpec the functions @reverse@, @++@ and @[]@, and 24 | it will find six laws: 25 | . 26 | > reverse [] == [] 27 | > xs ++ [] == xs 28 | > [] ++ xs == xs 29 | > reverse (reverse xs) == xs 30 | > (xs ++ ys) ++ zs == xs ++ (ys ++ zs) 31 | > reverse xs ++ reverse ys == reverse (ys ++ xs) 32 | . 33 | QuickSpec can find equational laws as well as conditional equations. All 34 | you need to supply are the functions to test, as well as @Ord@ and 35 | @Arbitrary@ instances for QuickSpec to use in testing; the rest is 36 | automatic. 37 | . 38 | For information on how to use QuickSpec, see the documentation in the main 39 | module, "QuickSpec". You can also look in the 40 | @@ 41 | directory, for example at 42 | @@, 43 | @@, or 44 | @@. 45 | To read about how 46 | QuickSpec works, see our paper, 47 | . 48 | 49 | Extra-source-files: 50 | README.md 51 | examples/Arith.hs 52 | examples/Bools.hs 53 | examples/Composition.hs 54 | examples/Curry.hs 55 | examples/Geometry.hs 56 | examples/HugeLists.hs 57 | examples/IntSet.hs 58 | examples/ListMonad.hs 59 | examples/Lists.hs 60 | examples/Octonions.hs 61 | examples/Parsing.hs 62 | examples/PrettyPrinting.hs 63 | examples/PrettyPrintingModel.hs 64 | examples/Regex.hs 65 | examples/Sorted.hs 66 | examples/Zip.hs 67 | 68 | source-repository head 69 | type: git 70 | location: git://github.com/nick8325/quickspec.git 71 | branch: master 72 | 73 | library 74 | default-language: Haskell2010 75 | ghc-options: -W 76 | hs-source-dirs: src 77 | Exposed-modules: 78 | QuickSpec 79 | QuickSpec.Internal 80 | QuickSpec.Internal.Explore 81 | QuickSpec.Internal.Explore.Conditionals 82 | QuickSpec.Internal.Explore.Polymorphic 83 | QuickSpec.Internal.Explore.Schemas 84 | QuickSpec.Internal.Explore.Terms 85 | QuickSpec.Internal.Haskell 86 | QuickSpec.Internal.Haskell.Resolve 87 | QuickSpec.Internal.Parse 88 | QuickSpec.Internal.Prop 89 | QuickSpec.Internal.Pruning 90 | QuickSpec.Internal.Pruning.Background 91 | QuickSpec.Internal.Pruning.Twee 92 | QuickSpec.Internal.Pruning.Types 93 | QuickSpec.Internal.Pruning.UntypedTwee 94 | QuickSpec.Internal.Pruning.PartialApplication 95 | QuickSpec.Internal.Pruning.Conditionals 96 | QuickSpec.Internal.Term 97 | QuickSpec.Internal.Terminal 98 | QuickSpec.Internal.Testing 99 | QuickSpec.Internal.Testing.DecisionTree 100 | QuickSpec.Internal.Testing.QuickCheck 101 | QuickSpec.Internal.Type 102 | QuickSpec.Internal.Utils 103 | 104 | Build-depends: 105 | QuickCheck >= 2.14.2, 106 | quickcheck-instances >= 0.3.16, 107 | base >= 4.7 && < 5, 108 | constraints, 109 | containers, 110 | data-lens-light >= 0.1.1, 111 | dlist, 112 | random, 113 | spoon, 114 | template-haskell, 115 | transformers, 116 | twee-lib >= 2.5, 117 | uglymemo 118 | -------------------------------------------------------------------------------- /src/QuickSpec.hs: -------------------------------------------------------------------------------- 1 | -- | The main QuickSpec module. Everything you need to run QuickSpec lives here. 2 | -- 3 | -- To run QuickSpec, you need to tell it which functions to test. We call the 4 | -- list of functions the /signature/. Here is an example signature, which tells 5 | -- QuickSpec to test the @++@, @reverse@ and @[]@ functions: 6 | -- 7 | -- @ 8 | -- sig = [ 9 | -- `con` "++" ((++) :: [`A`] -> [`A`] -> [`A`]), 10 | -- `con` "reverse" (reverse :: [`A`] -> [`A`]), 11 | -- `con` "[]" ([] :: [`A`]) ] 12 | -- @ 13 | -- 14 | -- The `con` function, used above, adds a function to the signature, given its 15 | -- name and its value. When declaring polymorphic functions in the signature, 16 | -- we use the types `A` to `E` to represent type variables. 17 | -- Having defined this signature, we can say @`quickSpec` sig@ to test it and 18 | -- see the discovered equations. 19 | -- 20 | -- If you want to test functions over your own datatypes, those types need to 21 | -- implement `Arbitrary` and `Ord` (if the `Ord` instance is a problem, see `Observe`). 22 | -- You must also declare those instances to QuickSpec, by including them in the 23 | -- signature. For monomorphic types you can do this using `monoType`: 24 | -- 25 | -- @ 26 | -- data T = ... 27 | -- main = quickSpec [ 28 | -- ..., 29 | -- `monoType` (Proxy :: Proxy T)] 30 | -- @ 31 | -- 32 | -- You can only declare monomorphic types with `monoType`. If you want to test 33 | -- your own polymorphic types, you must explicitly declare `Arbitrary` and `Ord` 34 | -- instances using the `inst` function. You can also use the `generator` function 35 | -- to use a custom generator instead of the `Arbitrary` instance for a given type. 36 | -- 37 | -- You can also use QuickSpec to find conditional equations. To do so, you need 38 | -- to include some /predicates/ in the signature. These are functions returning 39 | -- `Bool` which can appear as conditions in other equations. Declaring a predicate 40 | -- works just like declaring a function, except that you declare it using 41 | -- `predicate` instead of `con`. 42 | -- 43 | -- You can also put certain options in the signature. The most useful is 44 | -- `withMaxTermSize', which you can use to tell QuickSpec to generate larger 45 | -- equations. 46 | -- 47 | -- The @@ 48 | -- directory contains many examples. Here are some interesting ones: 49 | -- 50 | -- * @@: a simple arithmetic example. Demonstrates basic use of QuickSpec. 51 | -- * @@: list functions. Demonstrates testing polymorphic functions. 52 | -- * @@: sorting. Demonstrates finding conditional equations. 53 | -- * @@: a few functions from "Data.IntSet". Demonstrates testing user-defined datatypes and finding conditional equations. 54 | -- * @@: pretty printing combinators. Demonstrates testing user-defined datatypes and using observational equality. 55 | -- * @@: parser combinators. Demonstrates testing polymorphic datatypes and using observational equality. 56 | -- 57 | -- You can also find some larger case studies in our paper, 58 | -- . 59 | 60 | {-# LANGUAGE ScopedTypeVariables #-} 61 | {-# LANGUAGE FlexibleContexts #-} 62 | {-# LANGUAGE TypeOperators #-} 63 | {-# LANGUAGE MultiParamTypeClasses #-} 64 | {-# LANGUAGE FunctionalDependencies #-} 65 | {-# LANGUAGE AllowAmbiguousTypes #-} 66 | {-# LANGUAGE ConstraintKinds #-} 67 | {-# LANGUAGE RankNTypes #-} 68 | module QuickSpec( 69 | -- * Running QuickSpec 70 | quickSpec, Sig, Signature(..), 71 | 72 | -- * Declaring functions and predicates 73 | con, predicate, predicateGen, 74 | -- ** Type variables for polymorphic functions 75 | A, B, C, D, E, 76 | 77 | -- * Declaring types 78 | monoType, monoTypeObserve, Observe(..), inst, generator, 79 | vars, monoTypeWithVars, monoTypeObserveWithVars, 80 | variableUse, VariableUse(..), 81 | 82 | -- * Declaring types: @TypeApplication@-friendly variants 83 | mono, monoObserve, monoVars, monoObserveVars, 84 | 85 | -- * Standard signatures 86 | -- | The \"prelude\": a standard signature containing useful functions 87 | -- like '++', which can be used as background theory. 88 | lists, arith, funs, bools, prelude, without, 89 | 90 | -- * Exploring functions in series 91 | background, series, 92 | 93 | -- * Including type class constraints (experimental, subject to change) 94 | type (==>), liftC, instanceOf, 95 | 96 | -- * Customising QuickSpec 97 | withMaxTermSize, withMaxTermDepth, withMaxTests, withMaxTestSize, withMaxFunctions, defaultTo, 98 | withPruningDepth, withPruningTermSize, withFixedSeed, 99 | withInferInstanceTypes, withPrintStyle, PrintStyle(..), 100 | withConsistencyCheck, withBackgroundStrings, 101 | 102 | -- * Integrating with QuickCheck 103 | (=~=), 104 | 105 | -- * Re-exported functionality 106 | Typeable, (:-)(..), Dict(..), Proxy(..), Arbitrary) where 107 | 108 | import QuickSpec.Internal 109 | import QuickSpec.Internal.Haskell(Observe(..), PrintStyle(..), (=~=)) 110 | import QuickSpec.Internal.Type(A, B, C, D, E) 111 | import QuickSpec.Internal.Explore.Schemas(VariableUse(..)) 112 | import Data.Typeable 113 | import Data.Constraint 114 | import Test.QuickCheck 115 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Explore.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE FlexibleContexts, PatternGuards, CPP #-} 3 | module QuickSpec.Internal.Explore where 4 | 5 | import QuickSpec.Internal.Explore.Polymorphic 6 | import QuickSpec.Internal.Testing 7 | import QuickSpec.Internal.Pruning 8 | import QuickSpec.Internal.Term 9 | import QuickSpec.Internal.Type 10 | import QuickSpec.Internal.Utils 11 | import QuickSpec.Internal.Prop 12 | import QuickSpec.Internal.Terminal 13 | import Control.Monad 14 | import Control.Monad.Trans.Class 15 | import Control.Monad.Trans.State.Strict 16 | import Text.Printf 17 | #if! MIN_VERSION_base(4,9,0) 18 | import Data.Semigroup(Semigroup(..)) 19 | #endif 20 | import Data.List 21 | 22 | newtype Enumerator a = Enumerator { enumerate :: Int -> [[a]] -> [a] } 23 | 24 | -- N.B. order matters! 25 | -- Later enumerators get to see terms which were generated by earlier ones. 26 | instance Semigroup (Enumerator a) where 27 | e1 <> e2 = Enumerator $ \n tss -> 28 | let us = enumerate e1 n tss 29 | vs = enumerate e2 n (appendAt n us tss) 30 | in us ++ vs 31 | instance Monoid (Enumerator a) where 32 | mempty = Enumerator (\_ _ -> []) 33 | mappend = (<>) 34 | 35 | mapEnumerator :: ([a] -> [a]) -> Enumerator a -> Enumerator a 36 | mapEnumerator f e = 37 | Enumerator $ \n tss -> 38 | f (enumerate e n tss) 39 | 40 | filterEnumerator :: (a -> Bool) -> Enumerator a -> Enumerator a 41 | filterEnumerator p e = 42 | mapEnumerator (filter p) e 43 | 44 | enumerateConstants :: Sized a => [a] -> Enumerator a 45 | enumerateConstants ts = Enumerator (\n _ -> [t | t <- ts, size t == n]) 46 | 47 | enumerateApplications :: Apply a => Enumerator a 48 | enumerateApplications = Enumerator $ \n tss -> 49 | [ unPoly v 50 | | i <- [0..n], 51 | t <- tss !! i, 52 | u <- tss !! (n-i), 53 | Just v <- [tryApply (poly t) (poly u)] ] 54 | 55 | filterUniverse :: Typed f => Universe -> Enumerator (Term f) -> Enumerator (Term f) 56 | filterUniverse univ e = 57 | filterEnumerator (`usefulForUniverse` univ) e 58 | 59 | sortTerms :: Ord b => (a -> b) -> Enumerator a -> Enumerator a 60 | sortTerms measure e = 61 | mapEnumerator (sortBy' measure) e 62 | 63 | quickSpec :: 64 | (Ord fun, Ord norm, FuncSized fun, Typed fun, Ord result, PrettyTerm fun, 65 | MonadPruner (Term fun) norm m, MonadTester testcase (Term fun) m, MonadTerminal m) => 66 | (Prop (Term fun) -> m ()) -> 67 | (Term fun -> testcase -> Maybe result) -> 68 | Int -> Int -> (Type -> VariableUse) -> Universe -> Enumerator (Term fun) -> m () 69 | quickSpec present eval maxSize maxCommutativeSize use univ enum = do 70 | let 71 | state0 = initialState use univ (\t -> size t <= maxCommutativeSize) eval 72 | 73 | loop m n _ | m > n = return () 74 | loop m n tss = do 75 | putStatus (printf "enumerating terms of size %d" m) 76 | let 77 | ts = enumerate (filterUniverse univ enum) m tss 78 | total = length ts 79 | consider (i, t) = do 80 | putStatus (printf "testing terms of size %d: %d/%d" m i total) 81 | res <- explore t 82 | putStatus (printf "testing terms of size %d: %d/%d" m i total) 83 | lift $ mapM_ present (result_props res) 84 | case res of 85 | Accepted _ -> return True 86 | Rejected _ -> return False 87 | us <- map snd <$> filterM consider (zip [1 :: Int ..] ts) 88 | clearStatus 89 | loop (m+1) n (appendAt m us tss) 90 | 91 | evalStateT (loop 0 maxSize (repeat [])) state0 92 | 93 | ---------------------------------------------------------------------- 94 | -- Functions that are not really to do with theory exploration, 95 | -- but are useful for printing the output nicely. 96 | ---------------------------------------------------------------------- 97 | 98 | pPrintSignature :: (Pretty a, Typed a) => [a] -> Doc 99 | pPrintSignature funs = 100 | text "== Functions ==" $$ 101 | vcat (map pPrintDecl decls) 102 | where 103 | decls = [ (prettyShow f, pPrintType (typ f)) | f <- funs ] 104 | maxWidth = maximum (0:map (length . fst) decls) 105 | pad xs = nest (maxWidth - length xs) (text xs) 106 | pPrintDecl (name, ty) = 107 | pad name <+> text "::" <+> ty 108 | 109 | -- Put an equation that defines the function f into the form f lhs = rhs. 110 | -- An equation defines f if: 111 | -- * it is of the form f lhs = rhs (or vice versa). 112 | -- * f is not a background function. 113 | -- * lhs only contains background functions. 114 | -- * rhs does not contain f. 115 | -- * all vars in rhs appear in lhs 116 | prettyDefinition :: Eq fun => [fun] -> Prop (Term fun) -> Prop (Term fun) 117 | prettyDefinition cons (lhs :=>: t :=: u) 118 | | Just (f, ts) <- defines u, 119 | f `notElem` funs t, 120 | null (usort (vars t) \\ vars ts) = 121 | lhs :=>: u :=: t 122 | -- In the case where t defines f, the equation is already oriented correctly 123 | | otherwise = lhs :=>: t :=: u 124 | where 125 | defines (Fun f :@: ts) 126 | | f `elem` cons, 127 | all (`notElem` cons) (funs ts) = Just (f, ts) 128 | defines _ = Nothing 129 | 130 | -- Transform x+(y+z) = y+(x+z) into associativity, if + is commutative 131 | prettyAC :: (Eq f, Eq norm) => (Term f -> norm) -> Prop (Term f) -> Prop (Term f) 132 | prettyAC norm (lhs :=>: Fun f :@: [Var x, Fun f1 :@: [Var y, Var z]] :=: Fun f2 :@: [Var y1, Fun f3 :@: [Var x1, Var z1]]) 133 | | f == f1, f1 == f2, f2 == f3, 134 | x == x1, y == y1, z == z1, 135 | x /= y, y /= z, x /= z, 136 | norm (Fun f :@: [Var x, Var y]) == norm (Fun f :@: [Var y, Var x]) = 137 | lhs :=>: Fun f :@: [Fun f :@: [Var x, Var y], Var z] :=: Fun f :@: [Var x, Fun f :@: [Var y, Var z]] 138 | prettyAC _ prop = prop 139 | 140 | -- Add a type signature when printing the equation x = y. 141 | disambiguatePropType :: Prop (Term fun) -> Doc 142 | disambiguatePropType (_ :=>: (Var x) :=: Var _) = 143 | text "::" <+> pPrintType (typ x) 144 | disambiguatePropType _ = pPrintEmpty 145 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Explore/Conditionals.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE PatternGuards #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE DeriveFunctor #-} 12 | module QuickSpec.Internal.Explore.Conditionals where 13 | 14 | import QuickSpec.Internal.Prop as Prop 15 | import QuickSpec.Internal.Term as Term 16 | import QuickSpec.Internal.Type 17 | import QuickSpec.Internal.Pruning 18 | import QuickSpec.Internal.Pruning.Background(Background(..)) 19 | import QuickSpec.Internal.Testing 20 | import QuickSpec.Internal.Terminal 21 | import QuickSpec.Internal.Utils 22 | import QuickSpec.Internal.Explore.Polymorphic 23 | import qualified Twee.Base as Twee 24 | import Data.List 25 | import Control.Monad 26 | import Control.Monad.Trans.Class 27 | import Control.Monad.IO.Class 28 | 29 | newtype Conditionals m a = Conditionals (m a) 30 | deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal) 31 | instance MonadTrans Conditionals where 32 | lift = Conditionals 33 | instance (Typed fun, Ord fun, PrettyTerm fun, Ord norm, MonadPruner (Term fun) norm m, Predicate fun, MonadTerminal m) => 34 | MonadPruner (Term fun) norm (Conditionals m) where 35 | normaliser = lift normaliser 36 | add = lift . add . conditionalise 37 | decodeNormalForm hole t = lift (decodeNormalForm hole t) 38 | 39 | conditionalsUniverse :: (Typed fun, Predicate fun) => [Type] -> [fun] -> Universe 40 | conditionalsUniverse tys funs = 41 | universe $ 42 | tys ++ 43 | (map typ funs) 44 | -- map Normal funs) -- ++ 45 | -- [ Constructor pred clas_test_case | pred <- funs, Predicate{..} <- [classify pred] ]) 46 | 47 | runConditionals :: 48 | (PrettyTerm fun, Ord norm, MonadPruner (Term fun) norm m, Predicate fun, MonadTerminal m) => 49 | [fun] -> Conditionals m a -> m a 50 | runConditionals preds mx = 51 | run (mapM_ considerPredicate preds >> mx) 52 | where 53 | run (Conditionals mx) = mx 54 | 55 | class Predicate fun where 56 | classify :: fun -> Classification fun 57 | 58 | data Classification fun = 59 | Predicate { clas_selectors :: [fun], clas_test_case :: Type, clas_true :: Term fun } 60 | | Selector { clas_index :: Int, clas_pred :: fun, clas_test_case :: Type } 61 | | Function 62 | deriving (Eq, Ord, Functor) 63 | 64 | {- 65 | data WithConstructor fun = 66 | Constructor fun Type 67 | | Normal fun 68 | deriving (Eq, Ord) 69 | -} 70 | 71 | predType :: TyCon -> [Type] -> Type 72 | predType name tys = 73 | Twee.build (Twee.app (Twee.fun name) tys) 74 | 75 | considerPredicate :: 76 | (PrettyTerm fun, Ord norm, MonadPruner (Term fun) norm m, Predicate fun, MonadTerminal m) => 77 | fun -> Conditionals m () 78 | considerPredicate f = 79 | case classify f of 80 | Predicate sels ty true -> do 81 | let 82 | x = Var (V ty 0) 83 | eqns = 84 | [Fun f :@: [Fun sel :$: x | sel <- sels] === true] 85 | mapM_ (lift . add) eqns 86 | _ -> return () 87 | 88 | considerConditionalising :: 89 | (Typed fun, Ord fun, PrettyTerm fun, Ord norm, MonadPruner (Term fun) norm m, Predicate fun, MonadTerminal m) => 90 | Prop (Term fun) -> Conditionals m () 91 | considerConditionalising (lhs :=>: t :=: u) = return () 92 | 93 | conditionalise :: (PrettyTerm fun, Typed fun, Ord fun, Predicate fun) => Prop (Term fun) -> Prop (Term fun) 94 | conditionalise (lhs :=>: t :=: u) = 95 | go lhs t u 96 | where 97 | -- Replace one predicate with a conditional 98 | go lhs t u = 99 | case [ (p, x, clas_selectors, clas_true) | Fun f :$: Var x <- subterms t ++ subterms u, Selector _ p _ <- [classify f], Predicate{..} <- [classify p] ] of 100 | [] -> sort lhs :=>: t :=: u 101 | ((p, x, sels, true):_) -> 102 | let 103 | n = freeVar [t, u] 104 | tys = typeArgs (typ p) 105 | xs = map Var (zipWith V tys [n..]) 106 | subs = [(Fun (sels !! i) :$: Var x, xs !! i) | i <- [0..length tys-1]] 107 | in 108 | go ((Fun p :@: xs :=: true):lhs) (replaceMany subs t) (replaceMany subs u) 109 | 110 | replace from to t 111 | | t == from = to 112 | replace from to (t :$: u) = 113 | replace from to t :$: replace from to u 114 | replace _ _ (Var x) = Var x 115 | replace _ _ (Fun f) = Fun f 116 | 117 | replaceMany subs t = 118 | foldr (uncurry replace) t subs 119 | 120 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Explore/Terms.hs: -------------------------------------------------------------------------------- 1 | -- Theory exploration which accepts one term at a time. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE RecordWildCards, FlexibleContexts, PatternGuards #-} 4 | module QuickSpec.Internal.Explore.Terms where 5 | 6 | import qualified Data.Map.Strict as Map 7 | import Data.Map(Map) 8 | import QuickSpec.Internal.Term 9 | import QuickSpec.Internal.Prop 10 | import QuickSpec.Internal.Type 11 | import QuickSpec.Internal.Pruning 12 | import QuickSpec.Internal.Testing 13 | import QuickSpec.Internal.Testing.DecisionTree hiding (Result, Singleton) 14 | import Control.Monad.Trans.State.Strict hiding (State) 15 | import Data.Lens.Light 16 | import QuickSpec.Internal.Utils 17 | import QuickSpec.Internal.Terminal 18 | 19 | data Terms testcase result term norm = 20 | Terms { 21 | -- Empty decision tree. 22 | tm_empty :: DecisionTree testcase result term, 23 | -- Terms already explored. These are stored in the *values* of the map. 24 | -- The keys are those terms but normalised. 25 | -- We do it like this so that explore can guarantee to always return 26 | -- the same representative for each equivalence class (see below). 27 | tm_terms :: Map norm term, 28 | -- Decision tree mapping test case results to terms. 29 | -- Terms are not stored normalised. 30 | -- Terms of different types must not be equal, because that results in 31 | -- ill-typed equations and bad things happening in the pruner. 32 | tm_tree :: Map Type (DecisionTree testcase result term) } 33 | 34 | tree = lens tm_tree (\x y -> y { tm_tree = x }) 35 | 36 | treeForType :: Type -> Lens (Terms testcase result term norm) (DecisionTree testcase result term) 37 | treeForType ty = reading (\Terms{..} -> keyDefault ty tm_empty # tree) 38 | 39 | initialState :: 40 | (term -> testcase -> Maybe result) -> 41 | Terms testcase result term norm 42 | initialState eval = 43 | Terms { 44 | tm_empty = empty eval, 45 | tm_terms = Map.empty, 46 | tm_tree = Map.empty } 47 | 48 | data Result term = 49 | -- Discovered a new law. 50 | Discovered (Prop term) 51 | -- Term is equal to an existing term so redundant. 52 | | Knew (Prop term) 53 | | Singleton 54 | 55 | -- The Prop returned is always t :=: u, where t is the term passed to explore 56 | -- and u is the representative of t's equivalence class, not normalised. 57 | -- The representatives of the equivalence classes are guaranteed not to change. 58 | -- 59 | -- Discovered properties are not added to the pruner. 60 | explore :: (Pretty term, Typed term, Ord norm, Ord result, MonadTester testcase term m, MonadPruner term norm m, MonadTerminal m) => 61 | term -> StateT (Terms testcase result term norm) m (Result term) 62 | explore t = do 63 | res <- explore' t 64 | --case res of 65 | -- Discovered prop -> putLine ("discovered " ++ prettyShow prop) 66 | -- Knew prop -> putLine ("knew " ++ prettyShow prop) 67 | -- Singleton -> putLine ("singleton " ++ prettyShow t) 68 | return res 69 | explore' :: (Pretty term, Typed term, Ord norm, Ord result, MonadTester testcase term m, MonadPruner term norm m) => 70 | term -> StateT (Terms testcase result term norm) m (Result term) 71 | explore' t = do 72 | norm <- normaliser 73 | exp norm $ \prop -> do 74 | res <- test prop 75 | case res of 76 | Untestable -> 77 | return Singleton 78 | TestPassed -> do 79 | return (Discovered prop) 80 | TestFailed tc -> do 81 | treeForType ty %= addTestCase tc 82 | exp norm $ 83 | error "returned counterexample failed to falsify property" 84 | 85 | where 86 | ty = typ t 87 | exp norm found = do 88 | tm@Terms{..} <- get 89 | case Map.lookup t' tm_terms of 90 | Just u -> return (Knew (t === u)) 91 | Nothing -> 92 | case insert t (tm ^. treeForType ty) of 93 | Distinct tree -> do 94 | put (setL (treeForType ty) tree tm { tm_terms = Map.insert t' t tm_terms }) 95 | return Singleton 96 | EqualTo u 97 | -- tm_terms is not kept normalised wrt the discovered laws; 98 | -- instead, we normalise it lazily like so. 99 | | t' == u' -> do 100 | put tm { tm_terms = Map.insert u' u tm_terms } 101 | return (Knew prop) 102 | -- Ask QuickCheck for a counterexample to the property. 103 | | otherwise -> found prop 104 | where 105 | u' = norm u 106 | prop = t === u 107 | where 108 | t' = norm t 109 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Haskell/Resolve.hs: -------------------------------------------------------------------------------- 1 | -- A data structure for resolving typeclass instances and similar at runtime. 2 | -- 3 | -- Takes as input a set of functions ("instances"), and a type, and 4 | -- tries to build a value of that type from the instances given. 5 | -- 6 | -- For example, given the instances 7 | -- ordList :: Dict (Arbitrary a) -> Dict (Arbitrary [a]) 8 | -- ordChar :: Dict (Arbitrary Char) 9 | -- and the target type Dict (Arbitrary [Char]), it will produce the value 10 | -- ordList ordChar :: Dict (Arbitrary [Char]). 11 | -- 12 | -- The instances can in fact be arbitrary Haskell functions - though 13 | -- their types must be such that the instance search will terminate. 14 | 15 | {-# OPTIONS_HADDOCK hide #-} 16 | {-# LANGUAGE RankNTypes, ScopedTypeVariables, CPP #-} 17 | module QuickSpec.Internal.Haskell.Resolve(Instances(..), inst, valueInst, findInstance, findValue) where 18 | 19 | import Twee.Base 20 | import QuickSpec.Internal.Type 21 | import Data.MemoUgly 22 | import Data.Functor.Identity 23 | import Data.Maybe 24 | import Data.Proxy 25 | import Control.Monad 26 | #if !MIN_VERSION_base(4,9,0) 27 | import Data.Semigroup(Semigroup(..)) 28 | #endif 29 | 30 | -- A set of instances. 31 | data Instances = 32 | Instances { 33 | -- The available instances. 34 | -- Each instance is a unary function; 'inst' sees to this. 35 | is_instances :: [Poly (Value Identity)], 36 | -- The resulting instance search function (memoised). 37 | is_find :: Type -> [Value Identity] } 38 | 39 | -- A smart constructor for Instances. 40 | makeInstances :: [Poly (Value Identity)] -> Instances 41 | makeInstances is = inst 42 | where 43 | inst = Instances is (memo (find_ inst . canonicaliseType)) 44 | 45 | instance Semigroup Instances where 46 | x <> y = makeInstances (is_instances x ++ is_instances y) 47 | instance Monoid Instances where 48 | mempty = makeInstances [] 49 | mappend = (<>) 50 | 51 | -- Create a single instance. 52 | inst :: Typeable a => a -> Instances 53 | inst x = valueInst (toValue (Identity x)) 54 | 55 | valueInst :: Value Identity -> Instances 56 | valueInst x = polyInst (poly x) 57 | where 58 | polyInst :: Poly (Value Identity) -> Instances 59 | polyInst x = 60 | -- Transform x into a single-argument function 61 | -- (see comment about is_instances). 62 | case typ x of 63 | -- A function of type a -> (b -> c) gets uncurried. 64 | App (F _ Arrow) (Cons _ (Cons (App (F _ Arrow) _) Empty)) -> 65 | polyInst (apply uncur x) 66 | App (F _ Arrow) _ -> 67 | makeInstances [x] 68 | -- A plain old value x (not a function) turns into \() -> x. 69 | _ -> 70 | makeInstances [apply delay x] 71 | where 72 | uncur = toPolyValue (uncurry :: (A -> B -> C) -> (A, B) -> C) 73 | delay = toPolyValue ((\x () -> x) :: A -> () -> A) 74 | 75 | -- Construct a value of a particular type. 76 | -- If the type is polymorphic, may return an instance of it. 77 | findValue :: Instances -> Type -> Maybe (Value Identity) 78 | findValue insts = listToMaybe . is_find insts . skolemiseTypeVars 79 | 80 | -- Given a type a, construct a value of type f a. 81 | -- If the type is polymorphic, may return an instance of it. 82 | findInstance :: forall f. Typeable f => Instances -> Type -> Maybe (Value f) 83 | findInstance insts ty = 84 | unwrapFunctor runIdentity <$> findValue insts ty' 85 | where 86 | ty' = typeRep (Proxy :: Proxy f) `applyType` ty 87 | 88 | -- The unmemoised version of the search algorithm. 89 | -- Knows how to apply unary functions, and also knows how to generate: 90 | -- * The unit type () 91 | -- * Pairs (a, b) - search for a and then for b 92 | -- These two are important because instValue encodes other instances 93 | -- using them. 94 | -- 95 | -- Invariant: the type of the returned value is an instance of the argument type. 96 | find_ :: Instances -> Type -> [Value Identity] 97 | find_ _ (App (F _ unit) Empty) 98 | | unit == tyCon (Proxy :: Proxy ()) = 99 | return (toValue (Identity ())) 100 | find_ insts (App (F _ pair) (Cons ty1 (Cons ty2 Empty))) 101 | | pair == tyCon (Proxy :: Proxy (,)) = do 102 | x <- is_find insts ty1 103 | sub <- maybeToList (match ty1 (typ x)) 104 | -- N.B.: subst sub ty2 because searching for x may have constrained y's type 105 | y <- is_find insts (subst sub ty2) 106 | sub <- maybeToList (match ty2 (typ y)) 107 | return (pairValues (liftM2 (,)) (typeSubst sub x) y) 108 | find_ insts ty = do 109 | -- Find a function whose result type unifies with ty. 110 | -- Rename it to avoid clashes with ty. 111 | fun <- fmap (polyRename ty) (is_instances insts) 112 | App (F _ Arrow) (Cons arg (Cons res Empty)) <- return (typ fun) 113 | sub <- maybeToList (unify ty res) 114 | fun <- return (typeSubst sub fun) 115 | arg <- return (typeSubst sub arg) 116 | -- Find an argument for that function and apply the function. 117 | val <- is_find insts arg 118 | sub <- maybeToList (match arg (typ val)) 119 | return (apply (typeSubst sub fun) val) 120 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Parse.hs: -------------------------------------------------------------------------------- 1 | -- | Parsing strings into properties. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GADTs, TypeOperators #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | module QuickSpec.Internal.Parse where 6 | 7 | import Control.Monad 8 | import Data.Char 9 | import QuickSpec.Internal.Prop 10 | import QuickSpec.Internal.Term hiding (char) 11 | import QuickSpec.Internal.Type 12 | import qualified Data.Label as Label 13 | import Text.ParserCombinators.ReadP 14 | 15 | class Parse fun a where 16 | parse :: ReadP fun -> ReadP a 17 | 18 | instance Parse fun Var where 19 | parse _ = do 20 | x <- satisfy isUpper 21 | xs <- munch isAlphaNum 22 | let name = x:xs 23 | -- Use Data.Label as an easy way to generate a variable number 24 | return (V typeVar (fromIntegral (Label.labelNum (Label.label name)))) 25 | 26 | instance (fun1 ~ fun, Apply (Term fun)) => Parse fun1 (Term fun) where 27 | parse pfun = 28 | parseApp <++ parseVar 29 | where 30 | parseVar = Var <$> parse pfun 31 | parseApp = do 32 | f <- pfun 33 | args <- parseArgs <++ return [] 34 | return (unPoly (foldl apply (poly (Fun f)) (map poly args))) 35 | parseArgs = between (char '(') (char ')') (sepBy (parse pfun) (char ',')) 36 | 37 | instance (Parse fun a, Typed a) => Parse fun (Equation a) where 38 | parse pfun = do 39 | t <- parse pfun 40 | string "=" 41 | u <- parse pfun 42 | -- Compute type unifier of t and u 43 | -- "maybe mzero return" injects Maybe into MonadPlus 44 | pt <- maybe mzero return (polyMgu (poly (typ t)) (poly (typ u))) 45 | t <- maybe mzero return (cast (unPoly pt) t) 46 | u <- maybe mzero return (cast (unPoly pt) u) 47 | return (t :=: u) 48 | 49 | instance (Parse fun a, Typed a) => Parse fun (Prop a) where 50 | parse pfun = do 51 | lhs <- sepBy (parse pfun) (string "&") 52 | unless (null lhs) (void (string "=>")) 53 | rhs <- parse pfun 54 | return (lhs :=>: rhs) 55 | 56 | parseProp :: (Parse fun a, Pretty a) => ReadP fun -> String -> a 57 | parseProp pfun xs = 58 | case readP_to_S (parse pfun <* eof) (filter (not . isSpace) xs) of 59 | [(x, [])] -> x 60 | ps -> error ("parse': got result " ++ prettyShow ps ++ " while parsing " ++ xs) 61 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Prop.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE DeriveGeneric, TypeFamilies, DeriveFunctor, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, TypeOperators, DeriveTraversable #-} 3 | module QuickSpec.Internal.Prop where 4 | 5 | import Data.Bool (bool) 6 | import Control.Monad 7 | import qualified Data.DList as DList 8 | import Data.Ord 9 | import QuickSpec.Internal.Type 10 | import QuickSpec.Internal.Utils 11 | import QuickSpec.Internal.Term hiding (first) 12 | import GHC.Generics(Generic) 13 | import qualified Data.Map.Strict as Map 14 | import Control.Monad.Trans.State.Strict 15 | import Data.List 16 | import Control.Arrow (first) 17 | 18 | data Prop a = 19 | (:=>:) { 20 | lhs :: [Equation a], 21 | rhs :: Equation a } 22 | deriving (Show, Generic, Functor, Traversable, Foldable) 23 | 24 | instance Symbolic f a => Symbolic f (Prop a) where 25 | termsDL (lhs :=>: rhs) = 26 | termsDL rhs `mplus` termsDL lhs 27 | subst sub (lhs :=>: rhs) = 28 | subst sub lhs :=>: subst sub rhs 29 | 30 | instance Ord a => Eq (Prop a) where 31 | x == y = x `compare` y == EQ 32 | instance Ord a => Ord (Prop a) where 33 | compare = comparing (\p -> (usort (lhs p), rhs p)) 34 | 35 | infix 4 :=>: 36 | 37 | literals :: Prop a -> [Equation a] 38 | literals p = rhs p:lhs p 39 | 40 | unitProp :: Equation a -> Prop a 41 | unitProp p = [] :=>: p 42 | 43 | mapFun :: (fun1 -> fun2) -> Prop (Term fun1) -> Prop (Term fun2) 44 | mapFun f = fmap (fmap f) 45 | 46 | mapTerm :: (Term fun1 -> Term fun2) -> Prop (Term fun1) -> Prop (Term fun2) 47 | mapTerm f (lhs :=>: rhs) = map (both f) lhs :=>: both f rhs 48 | where 49 | both f (t :=: u) = f t :=: f u 50 | 51 | mapTermM :: Monad m => (Term fun1 -> m (Term fun2)) -> Prop (Term fun1) -> m (Prop (Term fun2)) 52 | mapTermM f (lhs :=>: rhs) = do 53 | lhs <- mapM (both f) lhs 54 | rhs <- both f rhs 55 | return (lhs :=>: rhs) 56 | where 57 | both f (t :=: u) = liftM2 (:=:) (f t) (f u) 58 | 59 | instance Typed a => Typed (Prop a) where 60 | typ _ = typeOf True 61 | otherTypesDL p = DList.fromList (literals p) >>= typesDL 62 | typeSubst_ sub (lhs :=>: rhs) = 63 | map (typeSubst_ sub) lhs :=>: typeSubst_ sub rhs 64 | 65 | instance Pretty a => Pretty (Prop a) where 66 | pPrint ([] :=>: rhs) = pPrint rhs 67 | pPrint p = 68 | hsep (punctuate (text " &") (map pPrint (lhs p))) <+> text "=>" <+> pPrint (rhs p) 69 | 70 | data Equation a = a :=: a deriving (Show, Eq, Ord, Generic, Functor, Traversable, Foldable) 71 | 72 | instance Symbolic f a => Symbolic f (Equation a) where 73 | termsDL (t :=: u) = termsDL t `mplus` termsDL u 74 | subst sub (t :=: u) = subst sub t :=: subst sub u 75 | 76 | infix 5 :=: 77 | 78 | instance Typed a => Typed (Equation a) where 79 | typ (t :=: _) = typ t 80 | otherTypesDL (t :=: u) = otherTypesDL t `mplus` typesDL u 81 | typeSubst_ sub (x :=: y) = typeSubst_ sub x :=: typeSubst_ sub y 82 | 83 | instance Pretty a => Pretty (Equation a) where 84 | pPrintPrec _ _ (x :=: y) 85 | | isTrue x = pPrint y 86 | | isTrue y = pPrint x 87 | | otherwise = pPrint x <+> text "=" <+> pPrint y 88 | where 89 | -- XXX this is a hack 90 | isTrue x = show (pPrint x) == "True" 91 | 92 | infix 4 === 93 | (===) :: a -> a -> Prop a 94 | x === y = [] :=>: x :=: y 95 | 96 | ---------------------------------------------------------------------- 97 | -- Making properties look pretty (naming variables, etc.) 98 | ---------------------------------------------------------------------- 99 | 100 | prettyProp :: 101 | (Typed fun, Apply (Term fun), PrettyTerm fun) => 102 | (Type -> [String]) -> Prop (Term fun) -> Doc 103 | prettyProp cands = pPrint . snd . nameVars cands 104 | 105 | prettyPropQC :: 106 | (Typed fun, Apply (Term fun), PrettyTerm fun) => 107 | Type -> (Type -> Bool) -> Int -> (Type -> [String]) -> Prop (Term fun) -> Doc 108 | prettyPropQC default_to was_observed nth cands x 109 | = hang (text first_char <+> text "(" <+> ((text $ show $ show $ pPrint law))) 2 110 | $ hang (hsep [text ",", text "property", text "$"]) 4 111 | $ hang ppr_binds 4 112 | $ (ppr_ctx <+> with_sig lhs lhs_type <+> eq_fn <+> pPrint rhs) <> text ")" 113 | where 114 | eq = "===" 115 | obs_eq = "=~=" 116 | eq_fn = text $ bool eq obs_eq $ was_observed lhs_type 117 | lhs_type = typ lhs_for_type 118 | 119 | first_char = 120 | case nth of 121 | 1 -> "[" 122 | _ -> "," 123 | ppr_ctx = 124 | case length ctx of 125 | 0 -> pPrintEmpty 126 | _ -> (hsep $ punctuate (text " &&") $ fmap (parens . pPrint) ctx) <+> text "==>" 127 | 128 | (_ :=>: (lhs_for_type :=: _)) = x 129 | (var_defs, law@(ctx :=>: (lhs :=: rhs))) = nameVars cands x 130 | with_sig expr ty = print_sig (pPrint expr) ty 131 | print_sig doc ty = parens $ doc <+> text "::" <+> pPrintType (defaultTo default_to ty) 132 | ppr_binds = 133 | case Map.size var_defs of 134 | 0 -> pPrintEmpty 135 | _ -> (text "\\ " <> sep (fmap (uncurry print_sig) (fmap (first text) $ Map.assocs var_defs))) <+> text "->" 136 | 137 | 138 | data Named fun = Name String | Ordinary fun 139 | instance Pretty fun => Pretty (Named fun) where 140 | pPrintPrec _ _ (Name name) = text name 141 | pPrintPrec l p (Ordinary fun) = pPrintPrec l p fun 142 | instance PrettyTerm fun => PrettyTerm (Named fun) where 143 | termStyle Name{} = curried 144 | termStyle (Ordinary fun) = termStyle fun 145 | 146 | nameVars :: (Type -> [String]) -> Prop (Term fun) -> (Map.Map String Type, Prop (Term (Named fun))) 147 | nameVars cands p = 148 | (var_defs, subst (\x -> Map.findWithDefault undefined x sub) (fmap (fmap Ordinary) p)) 149 | where 150 | sub = Map.fromList sub_map 151 | (sub_map, var_defs) = (runState (mapM assign (nub (vars p))) Map.empty) 152 | assign x = do 153 | s <- get 154 | let ty = typ x 155 | names = supply (cands ty) 156 | name = head (filter (`Map.notMember` s) names) 157 | modify (Map.insert name ty) 158 | return (x, Fun (Name name)) 159 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Pruning.hs: -------------------------------------------------------------------------------- 1 | -- A type of pruners. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, FlexibleInstances, UndecidableInstances, DefaultSignatures, GADTs, TypeOperators, DeriveFunctor, DeriveTraversable #-} 4 | module QuickSpec.Internal.Pruning where 5 | 6 | import QuickSpec.Internal.Prop 7 | import QuickSpec.Internal.Testing 8 | import QuickSpec.Internal.Type(Type) 9 | import Twee.Pretty 10 | import Control.Monad.Trans.Class 11 | import Control.Monad.IO.Class 12 | import Control.Monad.Trans.State.Strict 13 | import Control.Monad.Trans.Reader 14 | import Data.Maybe 15 | 16 | data Theorem norm = 17 | Theorem { 18 | prop :: Prop norm, 19 | axiomsUsed :: [(Prop norm, [Prop norm])] } 20 | deriving (Functor, Foldable, Traversable) 21 | 22 | instance Pretty norm => Pretty (Theorem norm) where 23 | pPrint thm = 24 | (text "prop =" <+> pPrint (prop thm)) $$ 25 | (text "axioms used =" <+> pPrint (axiomsUsed thm)) 26 | 27 | class Monad m => MonadPruner term norm m | m -> term norm where 28 | normaliser :: m (term -> norm) 29 | add :: Prop term -> m Bool 30 | decodeNormalForm :: (Type -> Maybe term) -> norm -> m (Maybe term) 31 | normTheorems :: m [Theorem norm] 32 | 33 | default normaliser :: (MonadTrans t, MonadPruner term norm m', m ~ t m') => m (term -> norm) 34 | normaliser = lift normaliser 35 | 36 | default add :: (MonadTrans t, MonadPruner term norm m', m ~ t m') => Prop term -> m Bool 37 | add = lift . add 38 | 39 | default normTheorems :: (MonadTrans t, MonadPruner term' norm m', m ~ t m') => m [Theorem norm] 40 | normTheorems = lift normTheorems 41 | 42 | default decodeNormalForm :: (MonadTrans t, MonadPruner term norm m', m ~ t m') => (Type -> Maybe term) -> norm -> m (Maybe term) 43 | decodeNormalForm hole t = lift (decodeNormalForm hole t) 44 | 45 | decodeTheorem :: MonadPruner term norm m => (Type -> Maybe term) -> Theorem norm -> m (Maybe (Theorem term)) 46 | decodeTheorem hole thm = elimMaybeThm <$> mapM (decodeNormalForm hole) thm 47 | where 48 | elimMaybeThm (Theorem prop axs) = 49 | case sequence prop of 50 | Nothing -> Nothing 51 | Just prop -> Just (Theorem prop (mapMaybe elimMaybeAx axs)) 52 | elimMaybeAx (ax, insts) = 53 | case sequence ax of 54 | Nothing -> Nothing 55 | Just ax -> Just (ax, mapMaybe elimMaybeInst insts) 56 | elimMaybeInst = sequence 57 | 58 | theorems :: MonadPruner term norm m => (Type -> Maybe term) -> m [Theorem term] 59 | theorems hole = do 60 | thms <- normTheorems 61 | catMaybes <$> mapM (decodeTheorem hole) thms 62 | 63 | instance MonadPruner term norm m => MonadPruner term norm (StateT s m) 64 | instance MonadPruner term norm m => MonadPruner term norm (ReaderT r m) 65 | 66 | normalise :: MonadPruner term norm m => term -> m norm 67 | normalise t = do 68 | norm <- normaliser 69 | return (norm t) 70 | 71 | newtype ReadOnlyPruner m a = ReadOnlyPruner { withReadOnlyPruner :: m a } 72 | deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term) 73 | 74 | instance MonadTrans ReadOnlyPruner where 75 | lift = ReadOnlyPruner 76 | 77 | instance MonadPruner term norm m => MonadPruner term norm (ReadOnlyPruner m) where 78 | normaliser = ReadOnlyPruner normaliser 79 | add _ = return True 80 | 81 | newtype WatchPruner term m a = WatchPruner (StateT [Prop term] m a) 82 | deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadTester testcase term) 83 | 84 | instance MonadPruner term norm m => MonadPruner term norm (WatchPruner term m) where 85 | normaliser = lift normaliser 86 | add prop = do 87 | res <- lift (add prop) 88 | WatchPruner (modify (prop:)) 89 | return res 90 | 91 | watchPruner :: Monad m => WatchPruner term m a -> m (a, [Prop term]) 92 | watchPruner (WatchPruner mx) = do 93 | (x, props) <- runStateT mx [] 94 | return (x, reverse props) 95 | 96 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Pruning/Background.hs: -------------------------------------------------------------------------------- 1 | -- A pruning layer which automatically adds axioms about functions as they appear. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, UndecidableInstances, TypeOperators #-} 4 | module QuickSpec.Internal.Pruning.Background where 5 | 6 | import QuickSpec.Internal.Term 7 | import QuickSpec.Internal.Testing 8 | import QuickSpec.Internal.Pruning 9 | import QuickSpec.Internal.Prop 10 | import QuickSpec.Internal.Terminal 11 | import qualified Data.Set as Set 12 | import Data.Set(Set) 13 | import Control.Monad 14 | import Control.Monad.IO.Class 15 | import Control.Monad.Trans.Class 16 | import Control.Monad.Trans.State.Strict hiding (State) 17 | 18 | newtype Pruner fun m a = 19 | Pruner (StateT (Set fun) m a) 20 | deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadTester testcase term, MonadTerminal) 21 | 22 | class Background f where 23 | background :: f -> [Prop (Term f)] 24 | background _ = [] 25 | 26 | run :: Monad m => Pruner fun m a -> m a 27 | run (Pruner x) = 28 | evalStateT x Set.empty 29 | 30 | instance (Ord fun, Background fun, MonadPruner (Term fun) norm m) => 31 | MonadPruner (Term fun) norm (Pruner fun m) where 32 | normaliser = lift normaliser 33 | add prop = do 34 | mapM_ addFunction (funs prop) 35 | lift (add prop) 36 | 37 | addFunction :: (Ord fun, Background fun, MonadPruner (Term fun) norm m) => fun -> Pruner fun m () 38 | addFunction f = do 39 | funcs <- Pruner get 40 | unless (f `Set.member` funcs) $ do 41 | Pruner (put (Set.insert f funcs)) 42 | mapM_ add (background f) 43 | 44 | instance (Background fun1, Background fun2) => Background (fun1 :+: fun2) where 45 | background (Inl x) = map (fmap (fmap Inl)) (background x) 46 | background (Inr x) = map (fmap (fmap Inr)) (background x) 47 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Pruning/Conditionals.hs: -------------------------------------------------------------------------------- 1 | -- Encode conditionals during pruning. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} 4 | module QuickSpec.Internal.Pruning.Conditionals where 5 | 6 | import QuickSpec.Internal.Pruning 7 | import QuickSpec.Internal.Pruning.Background(Background(..)) 8 | import QuickSpec.Internal.Testing 9 | import QuickSpec.Internal.Term 10 | import QuickSpec.Internal.Type 11 | import QuickSpec.Internal.Prop hiding (mapFun) 12 | import QuickSpec.Internal.Terminal 13 | import QuickSpec.Internal.Utils 14 | import Control.Monad.IO.Class 15 | import Control.Monad.Trans.Class 16 | 17 | data Conditionals fun = 18 | Func fun 19 | | Guard Type (UnconditionalTerm fun) (UnconditionalTerm fun) (UnconditionalTerm fun) (UnconditionalTerm fun) [Var] 20 | deriving (Eq, Ord, Show, Typeable) 21 | 22 | instance Arity fun => Arity (Conditionals fun) where 23 | arity (Func f) = arity f 24 | arity (Guard _ _ _ _ _ vs) = length vs + 1 25 | 26 | instance Sized fun => Sized (Conditionals fun) where 27 | size (Func f) = size f 28 | size Guard{} = 0 29 | 30 | instance Sized fun => FuncSized (Conditionals fun) where 31 | -- Note: since there is no FuncSized instance for PartiallyApplied 32 | -- we just assume that Func f is adding the size of its arguments 33 | sizeApp (Func f) ts = size f + sum ts 34 | sizeApp Guard{} ts = penalty + maximum ts 35 | where 36 | penalty = 3 37 | 38 | instance Pretty fun => Pretty (Conditionals fun) where 39 | pPrint (Func f) = pPrint f 40 | pPrint Guard{} = text "guard" 41 | 42 | instance PrettyTerm fun => PrettyTerm (Conditionals fun) where 43 | termStyle (Func f) = termStyle f 44 | termStyle Guard{} = uncurried 45 | 46 | instance Typed fun => Typed (Conditionals fun) where 47 | typ (Func f) = typ f 48 | typ (Guard ty t _ _ _ vs) = arrowType (typ t:map typ vs) ty 49 | 50 | typeSubst_ sub (Func f) = Func (typeSubst_ sub f) 51 | typeSubst_ sub (Guard ty t u v w vs) = Guard (typeSubst_ sub ty) (typeSubst_ sub t) (typeSubst_ sub u) (typeSubst_ sub v) (typeSubst_ sub w) (typeSubst_ sub vs) 52 | 53 | instance EqualsBonus (Conditionals fun) where 54 | 55 | type ConditionalTerm fun = Term fun 56 | type UnconditionalTerm fun = Term (Conditionals fun) 57 | 58 | newtype Pruner fun pruner a = 59 | Pruner { run :: pruner a } 60 | deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal) 61 | 62 | instance MonadTrans (Pruner fun) where 63 | lift = Pruner 64 | 65 | instance (PrettyTerm fun, Typed fun, MonadPruner (UnconditionalTerm fun) norm pruner) => MonadPruner (ConditionalTerm fun) norm (Pruner fun pruner) where 66 | normaliser = 67 | Pruner $ do 68 | norm <- normaliser :: pruner (UnconditionalTerm fun -> norm) 69 | 70 | return $ \t -> 71 | norm . mapFun Func $ t 72 | 73 | add prop = and <$> lift (mapM add (conditionalise' (canonicalise prop))) 74 | 75 | decodeNormalForm hole t = 76 | Pruner $ do 77 | t <- decodeNormalForm (fmap (fmap Func) . hole) t 78 | let elimIfEq (Func f) = Just f 79 | elimIfEq Guard{} = Nothing 80 | return $ t >>= mapFunM elimIfEq 81 | 82 | instance (Typed fun, Arity fun, Background fun) => Background (Conditionals fun) where 83 | background (Func f) = concatMap conditionalise' (background f) 84 | background Guard{} = [] 85 | 86 | conditionalise :: Typed fun => Prop (UnconditionalTerm fun) -> [Prop (UnconditionalTerm fun)] 87 | conditionalise prop@([] :=>: _) = [prop] 88 | conditionalise ((t :=: u):lhs :=>: v :=: w) = 89 | ([] :=>: guarded t v):conditionalise (lhs :=>: guarded u w) 90 | where 91 | guarded x y = Fun (Guard ty t u v w vs) :@: (x:map Var vs) :=: y 92 | vs = usort (concatMap vars [t, u, v, w]) 93 | ty = typ t 94 | 95 | conditionalise' :: Typed fun => Prop (ConditionalTerm fun) -> [Prop (UnconditionalTerm fun)] 96 | conditionalise' = conditionalise . mapTerm (mapFun Func) 97 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Pruning/PartialApplication.hs: -------------------------------------------------------------------------------- 1 | -- Pruning support for partial application and the like. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, RecordWildCards, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, UndecidableInstances, DeriveFunctor #-} 4 | module QuickSpec.Internal.Pruning.PartialApplication where 5 | 6 | import QuickSpec.Internal.Term as Term 7 | import QuickSpec.Internal.Type 8 | import QuickSpec.Internal.Pruning.Background hiding (Pruner) 9 | import QuickSpec.Internal.Pruning 10 | import QuickSpec.Internal.Prop as Prop 11 | import QuickSpec.Internal.Terminal 12 | import QuickSpec.Internal.Testing 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Trans.Class 15 | 16 | data PartiallyApplied f = 17 | -- A partially-applied function symbol. 18 | -- The Int describes how many arguments the function expects. 19 | Partial f Int 20 | -- The ($) operator, for oversaturated applications. 21 | -- The type argument is the type of the first argument to ($). 22 | | Apply Type 23 | deriving (Eq, Ord, Functor) 24 | 25 | instance Sized f => Sized (PartiallyApplied f) where 26 | size (Partial f _) = size f 27 | size (Apply _) = 1 28 | 29 | instance Arity (PartiallyApplied f) where 30 | arity (Partial _ n) = n 31 | arity (Apply _) = 2 32 | 33 | instance Pretty f => Pretty (PartiallyApplied f) where 34 | pPrint (Partial f n) = pPrint f <#> text "@" <#> pPrint n 35 | pPrint (Apply _) = text "$" 36 | 37 | instance PrettyTerm f => PrettyTerm (PartiallyApplied f) where 38 | termStyle (Partial f _) = termStyle f 39 | termStyle (Apply _) = infixStyle 2 40 | 41 | instance Typed f => Typed (PartiallyApplied f) where 42 | typ (Apply ty) = arrowType [ty] ty 43 | typ (Partial f _) = typ f 44 | otherTypesDL (Apply _) = mempty 45 | otherTypesDL (Partial f _) = otherTypesDL f 46 | typeSubst_ sub (Apply ty) = Apply (typeSubst_ sub ty) 47 | typeSubst_ sub (Partial f n) = Partial (typeSubst_ sub f) n 48 | 49 | partial :: f -> Term (PartiallyApplied f) 50 | partial f = Fun (Partial f 0) 51 | 52 | total :: Arity f => f -> PartiallyApplied f 53 | total f = Partial f (arity f) 54 | 55 | smartApply :: 56 | Typed f => Term (PartiallyApplied f) -> Term (PartiallyApplied f) -> Term (PartiallyApplied f) 57 | smartApply (Fun (Partial f n) :@: ts) u = 58 | Fun (Partial f (n+1)) :@: (ts ++ [u]) 59 | smartApply t u = simpleApply t u 60 | 61 | simpleApply :: 62 | Typed f => 63 | Term (PartiallyApplied f) -> Term (PartiallyApplied f) -> Term (PartiallyApplied f) 64 | simpleApply t u = 65 | Fun (Apply (typ t)) :@: [t, u] 66 | 67 | instance (Typed f, Background f) => Background (PartiallyApplied f) where 68 | background (Partial f _) = 69 | map (Prop.mapFun (\f -> Partial f arity)) (background f) ++ 70 | [ simpleApply (partial n) (vs !! n) === partial (n+1) 71 | | n <- [0..arity-1] ] 72 | where 73 | arity = typeArity (typ f) 74 | partial i = 75 | Fun (Partial f i) :@: take i vs 76 | vs = map Var (zipWith V (typeArgs (typ f)) [0..]) 77 | background _ = [] 78 | 79 | newtype Pruner fun pruner a = 80 | Pruner { run :: pruner a } 81 | deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal) 82 | 83 | instance MonadTrans (Pruner fun) where 84 | lift = Pruner 85 | 86 | instance (PrettyTerm fun, Typed fun, MonadPruner (Term (PartiallyApplied fun)) norm pruner) => MonadPruner (Term fun) norm (Pruner fun pruner) where 87 | normaliser = 88 | Pruner $ do 89 | norm <- normaliser 90 | return $ \t -> 91 | norm . encode $ t 92 | 93 | add prop = 94 | Pruner $ do 95 | add (encode <$> canonicalise prop) 96 | 97 | decodeNormalForm hole t = 98 | Pruner $ do 99 | t <- decodeNormalForm (fmap (fmap (flip Partial 0)) . hole) t 100 | let f (Partial x _) = NotId x 101 | f (Apply _) = Id 102 | return $ t >>= eliminateId . Term.mapFun f 103 | 104 | encode :: Typed fun => Term fun -> Term (PartiallyApplied fun) 105 | encode (Var x) = Var x 106 | encode (Fun f) = partial f 107 | encode (t :$: u) = smartApply (encode t) (encode u) 108 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Pruning/Twee.hs: -------------------------------------------------------------------------------- 1 | -- A pruner that uses twee. Supports types and background axioms. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE RecordWildCards, FlexibleContexts, FlexibleInstances, GADTs, PatternSynonyms, GeneralizedNewtypeDeriving, MultiParamTypeClasses, UndecidableInstances #-} 4 | module QuickSpec.Internal.Pruning.Twee(Config(..), module QuickSpec.Internal.Pruning.Twee) where 5 | 6 | import QuickSpec.Internal.Testing 7 | import QuickSpec.Internal.Pruning 8 | import QuickSpec.Internal.Term 9 | import QuickSpec.Internal.Terminal 10 | import qualified QuickSpec.Internal.Pruning.Types as Types 11 | import QuickSpec.Internal.Pruning.Types(Tagged) 12 | import qualified QuickSpec.Internal.Pruning.PartialApplication as PartialApplication 13 | import QuickSpec.Internal.Pruning.PartialApplication(PartiallyApplied) 14 | import qualified QuickSpec.Internal.Pruning.Background as Background 15 | import Control.Monad.Trans.Class 16 | import Control.Monad.IO.Class 17 | import qualified QuickSpec.Internal.Pruning.UntypedTwee as Untyped 18 | import qualified QuickSpec.Internal.Pruning.Conditionals as Conditionals 19 | import QuickSpec.Internal.Pruning.Conditionals(Conditionals) 20 | import QuickSpec.Internal.Pruning.UntypedTwee(Config(..)) 21 | import Data.Typeable 22 | 23 | newtype Pruner fun m a = 24 | Pruner (PartialApplication.Pruner fun (Conditionals.Pruner (PartiallyApplied fun) (Types.Pruner (Conditionals (PartiallyApplied fun)) (Background.Pruner (Tagged (Conditionals (PartiallyApplied fun))) (Untyped.Pruner (Tagged (Conditionals (PartiallyApplied fun))) m)))) a) 25 | deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, 26 | MonadPruner (Term fun) (Untyped.Norm (Tagged (Conditionals (PartiallyApplied fun)))), MonadTerminal) 27 | 28 | instance MonadTrans (Pruner fun) where 29 | lift = Pruner . lift . lift . lift . lift . lift 30 | 31 | run :: (Sized fun, Typeable fun, Ord fun, PrettyTerm fun, Monad m) => Config -> Pruner fun m a -> m a 32 | run config (Pruner x) = 33 | Untyped.run config (Background.run (Types.run (Conditionals.run (PartialApplication.run x)))) 34 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Pruning/Types.hs: -------------------------------------------------------------------------------- 1 | -- Encode monomorphic types during pruning. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} 4 | module QuickSpec.Internal.Pruning.Types where 5 | 6 | import QuickSpec.Internal.Pruning 7 | import QuickSpec.Internal.Pruning.Background(Background(..)) 8 | import QuickSpec.Internal.Testing 9 | import QuickSpec.Internal.Term 10 | import QuickSpec.Internal.Type 11 | import QuickSpec.Internal.Prop hiding (mapFun) 12 | import QuickSpec.Internal.Terminal 13 | import Control.Monad.IO.Class 14 | import Control.Monad.Trans.Class 15 | 16 | data Tagged fun = 17 | Func fun 18 | | Tag Type 19 | deriving (Eq, Ord, Show, Typeable) 20 | 21 | instance Arity fun => Arity (Tagged fun) where 22 | arity (Func f) = arity f 23 | arity (Tag _) = 1 24 | 25 | instance Sized fun => Sized (Tagged fun) where 26 | size (Func f) = size f 27 | size (Tag _) = 0 28 | 29 | instance FuncSized fun => FuncSized (Tagged fun) where 30 | sizeApp (Func f) ts = sizeApp f ts 31 | sizeApp (Tag t) ts = sum ts 32 | 33 | instance Pretty fun => Pretty (Tagged fun) where 34 | pPrint (Func f) = pPrint f 35 | pPrint (Tag ty) = text "tag[" <#> pPrint ty <#> text "]" 36 | 37 | instance PrettyTerm fun => PrettyTerm (Tagged fun) where 38 | termStyle (Func f) = termStyle f 39 | termStyle (Tag _) = uncurried 40 | 41 | instance Typed fun => Typed (Tagged fun) where 42 | typ (Func f) = typ f 43 | typ (Tag ty) = arrowType [ty] ty 44 | 45 | typeSubst_ sub (Func f) = Func (typeSubst_ sub f) 46 | typeSubst_ sub (Tag ty) = Tag (typeSubst_ sub ty) 47 | 48 | instance EqualsBonus (Tagged fun) where 49 | 50 | type TypedTerm fun = Term fun 51 | type UntypedTerm fun = Term (Tagged fun) 52 | 53 | newtype Pruner fun pruner a = 54 | Pruner { run :: pruner a } 55 | deriving (Functor, Applicative, Monad, MonadIO, MonadTester testcase term, MonadTerminal) 56 | 57 | instance MonadTrans (Pruner fun) where 58 | lift = Pruner 59 | 60 | instance (PrettyTerm fun, Typed fun, MonadPruner (UntypedTerm fun) norm pruner) => MonadPruner (TypedTerm fun) norm (Pruner fun pruner) where 61 | normaliser = 62 | Pruner $ do 63 | norm <- normaliser :: pruner (UntypedTerm fun -> norm) 64 | 65 | -- Note that we don't call addFunction on the functions in the term. 66 | -- This is because doing so might be expensive, as adding typing 67 | -- axioms starts the completion algorithm. 68 | -- This is OK because in encode, we tag all functions and variables 69 | -- with their types (i.e. we can fall back to the naive type encoding). 70 | return $ \t -> 71 | norm . encode $ t 72 | 73 | add prop = lift (add (encode <$> canonicalise prop)) 74 | 75 | decodeNormalForm hole t = 76 | Pruner $ do 77 | t <- decodeNormalForm (fmap (fmap Func) . hole) t 78 | let f (Func x) = NotId x 79 | f (Tag _) = Id 80 | return $ t >>= eliminateId . mapFun f 81 | 82 | instance (Typed fun, Arity fun, Background fun) => Background (Tagged fun) where 83 | background = typingAxioms 84 | 85 | -- Compute the typing axioms for a function or type tag. 86 | typingAxioms :: (Typed fun, Arity fun, Background fun) => 87 | Tagged fun -> [Prop (UntypedTerm fun)] 88 | typingAxioms (Tag ty) = 89 | [tag ty (tag ty x) === tag ty x] 90 | where 91 | x = Var (V ty 0) 92 | typingAxioms (Func func) = 93 | [tag res t === t] ++ 94 | [tagArg i ty === t | (i, ty) <- zip [0..] args] ++ 95 | map (fmap encode) (background func) 96 | where 97 | f = Fun (Func func) 98 | xs = take n (map (Var . V typeVar) [0..]) 99 | 100 | ty = typ func 101 | -- Use arity rather than typeArity, so that we can support 102 | -- partially-applied functions 103 | n = arity func 104 | args = take n (typeArgs ty) 105 | res = typeDrop n ty 106 | 107 | t = f :@: xs 108 | 109 | tagArg i ty = 110 | f :@: 111 | (take i xs ++ 112 | [tag ty (xs !! i)] ++ 113 | drop (i+1) xs) 114 | 115 | tag :: Type -> UntypedTerm fun -> UntypedTerm fun 116 | tag ty t = Fun (Tag ty) :$: t 117 | 118 | encode :: Typed fun => TypedTerm fun -> UntypedTerm fun 119 | -- We always add type tags; see comment in normaliseMono. 120 | -- In the common case, twee will immediately remove these surplus type tags 121 | -- by rewriting using the typing axioms. 122 | encode (Var x) = tag (typ x) (Var x) 123 | encode (Fun f :@: ts) = 124 | tag (typeDrop (length ts) (typ f)) (Fun (Func f) :@: map encode ts) 125 | encode _ = error "partial application" 126 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures, GADTs, TypeOperators #-} 3 | module QuickSpec.Internal.Terminal where 4 | 5 | import Control.Monad.Trans.Class 6 | import Control.Monad.IO.Class 7 | import Control.Monad.Trans.State.Strict 8 | import Control.Monad.Trans.Reader 9 | import qualified Test.QuickCheck.Text as Text 10 | 11 | class Monad m => MonadTerminal m where 12 | putText :: String -> m () 13 | putLine :: String -> m () 14 | putTemp :: String -> m () 15 | 16 | default putText :: (MonadTrans t, MonadTerminal m', m ~ t m') => String -> m () 17 | putText = lift . putText 18 | 19 | default putLine :: (MonadTrans t, MonadTerminal m', m ~ t m') => String -> m () 20 | putLine = lift . putLine 21 | 22 | default putTemp :: (MonadTrans t, MonadTerminal m', m ~ t m') => String -> m () 23 | putTemp = lift . putTemp 24 | 25 | instance MonadTerminal m => MonadTerminal (StateT s m) 26 | instance MonadTerminal m => MonadTerminal (ReaderT r m) 27 | 28 | putStatus :: MonadTerminal m => String -> m () 29 | putStatus str = putTemp ("[" ++ str ++ "...]") 30 | 31 | clearStatus :: MonadTerminal m => m () 32 | clearStatus = putTemp "" 33 | 34 | withStatus :: MonadTerminal m => String -> m a -> m a 35 | withStatus str mx = putStatus str *> mx <* clearStatus 36 | 37 | newtype Terminal a = Terminal (ReaderT Text.Terminal IO a) 38 | deriving (Functor, Applicative, Monad, MonadIO) 39 | 40 | instance MonadTerminal Terminal where 41 | putText str = Terminal $ do 42 | term <- ask 43 | liftIO $ Text.putPart term str 44 | 45 | putLine str = Terminal $ do 46 | term <- ask 47 | liftIO $ Text.putLine term str 48 | 49 | putTemp str = Terminal $ do 50 | term <- ask 51 | liftIO $ Text.putTemp term str 52 | 53 | withNullTerminal :: Terminal a -> IO a 54 | withNullTerminal (Terminal mx) = 55 | Text.withNullTerminal (runReaderT mx) 56 | 57 | withStdioTerminal :: Terminal a -> IO a 58 | withStdioTerminal (Terminal mx) = 59 | Text.withStdioTerminal (runReaderT mx) 60 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Testing.hs: -------------------------------------------------------------------------------- 1 | -- A type of test case generators. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FunctionalDependencies, DefaultSignatures, GADTs, FlexibleInstances, UndecidableInstances, TypeOperators, DeriveFunctor #-} 4 | module QuickSpec.Internal.Testing where 5 | 6 | import QuickSpec.Internal.Prop 7 | import Control.Monad.Trans.Class 8 | import Control.Monad.Trans.State.Strict 9 | import Control.Monad.Trans.Reader 10 | 11 | data TestResult testcase = 12 | TestPassed 13 | | TestFailed testcase 14 | | Untestable 15 | deriving (Functor, Eq) 16 | 17 | testResult :: TestResult testcase -> TestResult () 18 | testResult = fmap (const ()) 19 | 20 | testAnd :: TestResult testcase -> TestResult testcase -> TestResult testcase 21 | TestPassed `testAnd` x = x 22 | x `testAnd` _ = x 23 | 24 | testImplies :: TestResult testcase -> TestResult testcase -> TestResult testcase 25 | TestPassed `testImplies` x = x 26 | TestFailed _ `testImplies` _ = TestPassed 27 | Untestable `testImplies` _ = Untestable 28 | 29 | class Monad m => MonadTester testcase term m | m -> testcase term where 30 | test :: Prop term -> m (TestResult testcase) 31 | retest :: testcase -> Prop term -> m (TestResult testcase) 32 | 33 | default test :: (MonadTrans t, MonadTester testcase term m', m ~ t m') => Prop term -> m (TestResult testcase) 34 | test = lift . test 35 | 36 | default retest :: (MonadTrans t, MonadTester testcase term m', m ~ t m') => testcase -> Prop term -> m (TestResult testcase) 37 | retest tc = lift . retest tc 38 | 39 | instance MonadTester testcase term m => MonadTester testcase term (StateT s m) 40 | instance MonadTester testcase term m => MonadTester testcase term (ReaderT r m) 41 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Testing/DecisionTree.hs: -------------------------------------------------------------------------------- 1 | -- Decision trees for testing terms for equality. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module QuickSpec.Internal.Testing.DecisionTree where 5 | 6 | import qualified Data.Map as Map 7 | import Data.Map(Map) 8 | 9 | data DecisionTree testcase result term = 10 | DecisionTree { 11 | -- A function for evaluating terms on test cases. 12 | dt_evaluate :: term -> testcase -> Maybe result, 13 | -- The set of test cases gathered so far. 14 | dt_test_cases :: [testcase], 15 | -- The tree itself. 16 | dt_tree :: !(Maybe (InnerTree result term)) } 17 | 18 | data InnerTree result term = 19 | TestCase !(Map result (InnerTree result term)) 20 | | Singleton !term 21 | 22 | data Result testcase result term = 23 | Distinct (DecisionTree testcase result term) 24 | | EqualTo term 25 | 26 | -- Make a new decision tree. 27 | empty :: (term -> testcase -> Maybe result) -> DecisionTree testcase result term 28 | empty eval = 29 | DecisionTree { 30 | dt_evaluate = eval, 31 | dt_test_cases = [], 32 | dt_tree = Nothing } 33 | 34 | -- Add a new test case to a decision tree. 35 | addTestCase :: 36 | testcase -> DecisionTree testcase result term -> 37 | DecisionTree testcase result term 38 | addTestCase tc dt@DecisionTree{..} = 39 | dt{dt_test_cases = dt_test_cases ++ [tc]} 40 | 41 | -- Insert a value into a decision tree. 42 | insert :: Ord result => 43 | term -> DecisionTree testcase result term -> 44 | Result testcase result term 45 | insert x dt@DecisionTree{dt_tree = Nothing, ..} = 46 | Distinct dt{dt_tree = Just (Singleton x)} 47 | insert x dt@DecisionTree{dt_tree = Just dt_tree, ..} = 48 | aux k dt_test_cases dt_tree 49 | where 50 | k tree = dt{dt_tree = Just tree} 51 | aux _ [] (Singleton y) = EqualTo y 52 | aux k (t:ts) (Singleton y) = 53 | case dt_evaluate y t of 54 | Nothing -> 55 | -- y is untestable, so we can evict it from the tree 56 | Distinct (k (Singleton x)) 57 | Just val -> 58 | aux k (t:ts) $ 59 | TestCase (Map.singleton val (Singleton y)) 60 | aux k (t:ts) (TestCase res) = 61 | case dt_evaluate x t of 62 | Nothing -> 63 | Distinct (k (TestCase res)) 64 | Just val -> 65 | let 66 | k' tree = k (TestCase (Map.insert val tree res)) 67 | in case Map.lookup val res of 68 | Nothing -> 69 | Distinct (k' (Singleton x)) 70 | Just tree -> 71 | aux k' ts tree 72 | aux _ [] (TestCase _) = 73 | error "unexpected node in decision tree" 74 | 75 | data Statistics = 76 | Statistics { 77 | -- Total number of terms in the decision tree 78 | stat_num_terms :: !Int, 79 | -- Total number of tests executed 80 | stat_num_tests :: !Int, 81 | -- Number of distinct test cases used 82 | stat_num_test_cases :: !Int } 83 | deriving (Eq, Show) 84 | 85 | statistics :: DecisionTree testcase result term -> Statistics 86 | statistics DecisionTree{dt_tree = Nothing} = 87 | Statistics 0 0 0 88 | statistics DecisionTree{dt_tree = Just dt_tree, ..} = 89 | Statistics { 90 | stat_num_terms = x, 91 | stat_num_tests = y, 92 | stat_num_test_cases = length dt_test_cases } 93 | where 94 | (x, y) = stat dt_tree 95 | 96 | -- Returns (number of terms, number of tests) 97 | stat Singleton{} = (1, 0) 98 | -- To calculate the number of test cases, note that each term 99 | -- under res executed one test case on the way through this node. 100 | stat (TestCase res) = 101 | (sum (map fst ss), sum [ x + y | (x, y) <- ss ]) 102 | where 103 | ss = map stat (Map.elems res) 104 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Testing/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | -- Testing conjectures using QuickCheck. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} 4 | module QuickSpec.Internal.Testing.QuickCheck where 5 | 6 | import QuickSpec.Internal.Testing 7 | import QuickSpec.Internal.Pruning 8 | import QuickSpec.Internal.Prop 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Gen 11 | import Test.QuickCheck.Random 12 | import Control.Monad.IO.Class 13 | import Control.Monad.Trans.Class 14 | import Control.Monad.Trans.Reader 15 | import Data.List 16 | import System.Random hiding (uniform) 17 | import QuickSpec.Internal.Terminal 18 | import Data.Lens.Light 19 | 20 | data Config = 21 | Config { 22 | cfg_num_tests :: Int, 23 | cfg_max_test_size :: Int, 24 | cfg_fixed_seed :: Maybe QCGen} 25 | deriving Show 26 | 27 | lens_num_tests = lens cfg_num_tests (\x y -> y { cfg_num_tests = x }) 28 | lens_max_test_size = lens cfg_max_test_size (\x y -> y { cfg_max_test_size = x }) 29 | lens_fixed_seed = lens cfg_fixed_seed (\x y -> y { cfg_fixed_seed = x }) 30 | 31 | data Environment testcase term result = 32 | Environment { 33 | env_config :: Config, 34 | env_tests :: [testcase], 35 | env_eval :: testcase -> term -> Maybe result } 36 | 37 | newtype Tester testcase term result m a = 38 | Tester (ReaderT (Environment testcase term result) m a) 39 | deriving (Functor, Applicative, Monad, MonadIO, MonadTerminal, MonadPruner term' res') 40 | 41 | instance MonadTrans (Tester testcase term result) where 42 | lift = Tester . lift 43 | 44 | run :: 45 | Config -> Gen testcase -> (testcase -> term -> Maybe result) -> 46 | Tester testcase term result m a -> Gen (m a) 47 | run config@Config{..} gen eval (Tester x) = do 48 | seed <- maybe arbitrary return cfg_fixed_seed 49 | let 50 | seeds = unfoldr (Just . split) seed 51 | n = fromIntegral (ceiling (fromIntegral cfg_num_tests * (1 - zeroProportion))) 52 | zeroes = cfg_num_tests - n 53 | k = max 1 cfg_max_test_size 54 | bias = 3 55 | -- Run this proportion of tests of size 0. 56 | zeroProportion = 0.01 57 | -- Bias tests towards smaller sizes. 58 | -- We do this by distributing the cube of the size uniformly. 59 | sizes = 60 | replicate zeroes 0 ++ 61 | (reverse $ map (k -) $ 62 | map (truncate . (** (1/fromInteger bias)) . fromIntegral) $ 63 | uniform (toInteger n) (toInteger k^bias)) 64 | tests = zipWith (unGen gen) seeds sizes 65 | return $ runReaderT x 66 | Environment { 67 | env_config = config, 68 | env_tests = tests, 69 | env_eval = eval } 70 | 71 | -- uniform n k: generate a list of n integers which are distributed evenly between 0 and k-1. 72 | uniform :: Integer -> Integer -> [Integer] 73 | uniform n k = 74 | -- n `div` k: divide evenly as far as possible. 75 | concat [replicate (fromIntegral (n `div` k)) i | i <- [0..k-1]] ++ 76 | -- The leftovers get distributed at equal intervals. 77 | [i * k `div` leftovers | i <- [0..leftovers-1]] 78 | where 79 | leftovers = n `mod` k 80 | 81 | instance (Monad m, Eq result) => MonadTester testcase term (Tester testcase term result m) where 82 | test prop = 83 | Tester $ do 84 | env@Environment{..} <- ask 85 | return $! foldr testAnd TestPassed (map (quickCheckTest env prop) env_tests) 86 | retest testcase prop = 87 | Tester $ do 88 | env@Environment{..} <- ask 89 | return $! quickCheckTest env prop testcase 90 | 91 | quickCheckTest :: Eq result => 92 | Environment testcase term result -> Prop term -> testcase -> TestResult testcase 93 | quickCheckTest Environment{env_config = Config{..}, ..} (lhs :=>: rhs) testcase = 94 | foldr testAnd (testEq rhs) (map testEq lhs) 95 | where 96 | testEq (t :=: u) = 97 | case (env_eval testcase t, env_eval testcase u) of 98 | (Just t, Just u) 99 | | t == u -> TestPassed 100 | | otherwise -> TestFailed testcase 101 | _ -> Untestable 102 | -------------------------------------------------------------------------------- /src/QuickSpec/Internal/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | Miscellaneous utility functions. 2 | {-# OPTIONS_HADDOCK hide #-} 3 | {-# LANGUAGE CPP, ScopedTypeVariables #-} 4 | module QuickSpec.Internal.Utils where 5 | 6 | import Control.Arrow((&&&)) 7 | import Control.Exception 8 | import Control.Spoon 9 | import Data.List(groupBy, sortBy) 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Data.Monoid 12 | #endif 13 | import Data.Ord(comparing) 14 | import System.IO 15 | import qualified Control.Category as Category 16 | import qualified Data.Map.Strict as Map 17 | import Data.Map(Map) 18 | import Language.Haskell.TH.Syntax 19 | import Data.Lens.Light 20 | import Twee.Base hiding (lookup) 21 | import Control.Monad.Trans.State.Strict 22 | import Control.Monad 23 | import Data.Typeable 24 | 25 | (#) :: Category.Category cat => cat b c -> cat a b -> cat a c 26 | (#) = (Category..) 27 | 28 | key :: Ord a => a -> Lens (Map a b) (Maybe b) 29 | key x = lens (Map.lookup x) (\my m -> Map.alter (const my) x m) 30 | 31 | keyDefault :: Ord a => a -> b -> Lens (Map a b) b 32 | keyDefault x y = lens (Map.findWithDefault y x) (\y m -> Map.insert x y m) 33 | 34 | reading :: (a -> Lens a b) -> Lens a b 35 | reading f = lens (\x -> getL (f x) x) (\y x -> setL (f x) y x) 36 | 37 | fstLens :: Lens (a, b) a 38 | fstLens = lens fst (\x (_, y) -> (x, y)) 39 | 40 | sndLens :: Lens (a, b) b 41 | sndLens = lens snd (\y (x, _) -> (x, y)) 42 | 43 | makeLensAs :: Name -> [(String, String)] -> Q [Dec] 44 | makeLensAs ty names = 45 | nameMakeLens ty (\x -> lookup x names) 46 | 47 | repeatM :: Monad m => m a -> m [a] 48 | repeatM = sequence . repeat 49 | 50 | partitionBy :: Ord b => (a -> b) -> [a] -> [[a]] 51 | partitionBy value = 52 | map (map fst) . 53 | groupBy (\x y -> snd x == snd y) . 54 | sortBy (comparing snd) . 55 | map (id &&& value) 56 | 57 | collate :: Ord a => ([b] -> c) -> [(a, b)] -> [(a, c)] 58 | collate f = map g . partitionBy fst 59 | where 60 | g xs = (fst (head xs), f (map snd xs)) 61 | 62 | isSorted :: Ord a => [a] -> Bool 63 | isSorted xs = and (zipWith (<=) xs (tail xs)) 64 | 65 | isSortedBy :: Ord b => (a -> b) -> [a] -> Bool 66 | isSortedBy f xs = isSorted (map f xs) 67 | 68 | usort :: Ord a => [a] -> [a] 69 | usort = usortBy compare 70 | 71 | usortBy :: (a -> a -> Ordering) -> [a] -> [a] 72 | usortBy f = map head . groupBy (\x y -> f x y == EQ) . sortBy f 73 | 74 | sortBy' :: Ord b => (a -> b) -> [a] -> [a] 75 | sortBy' f = map snd . sortBy (comparing fst) . map (\x -> (f x, x)) 76 | 77 | usortBy' :: Ord b => (a -> b) -> [a] -> [a] 78 | usortBy' f = map snd . usortBy (comparing fst) . map (\x -> (f x, x)) 79 | 80 | orElse :: Ordering -> Ordering -> Ordering 81 | EQ `orElse` x = x 82 | x `orElse` _ = x 83 | 84 | unbuffered :: IO a -> IO a 85 | unbuffered x = do 86 | buf <- hGetBuffering stdout 87 | bracket_ 88 | (hSetBuffering stdout NoBuffering) 89 | (hSetBuffering stdout buf) 90 | x 91 | 92 | spoony :: Eq a => a -> Maybe a 93 | spoony x = teaspoon ((x == x) `seq` x) 94 | 95 | labelM :: Monad m => (a -> m b) -> [a] -> m [(a, b)] 96 | labelM f = mapM (\x -> do { y <- f x; return (x, y) }) 97 | 98 | #if __GLASGOW_HASKELL__ < 710 99 | isSubsequenceOf :: Ord a => [a] -> [a] -> Bool 100 | [] `isSubsequenceOf` ys = True 101 | (x:xs) `isSubsequenceOf` [] = False 102 | (x:xs) `isSubsequenceOf` (y:ys) 103 | | x == y = xs `isSubsequenceOf` ys 104 | | otherwise = (x:xs) `isSubsequenceOf` ys 105 | #endif 106 | 107 | appendAt :: Int -> [a] -> [[a]] -> [[a]] 108 | appendAt n xs [] = appendAt n xs [[]] 109 | appendAt 0 xs (ys:yss) = (ys ++ xs):yss 110 | appendAt n xs (ys:yss) = ys:appendAt (n-1) xs yss 111 | 112 | -- Should be in Twee.Base. 113 | antiunify :: Ord f => Term f -> Term f -> Term f 114 | antiunify t u = 115 | build $ evalState (loop t u) (succ (snd (bound t) `max` snd (bound u)), Map.empty) 116 | where 117 | loop (App f ts) (App g us) 118 | | f == g = 119 | app f <$> zipWithM loop (unpack ts) (unpack us) 120 | loop (Var x) (Var y) 121 | | x == y = 122 | return (var x) 123 | loop t u = do 124 | (next, m) <- get 125 | case Map.lookup (t, u) m of 126 | Just v -> return (var v) 127 | Nothing -> do 128 | put (succ next, Map.insert (t, u) next m) 129 | return (var next) 130 | 131 | {-# INLINE fixpoint #-} 132 | fixpoint :: Eq a => (a -> a) -> a -> a 133 | fixpoint f x = fxp x 134 | where 135 | fxp x 136 | | x == y = x 137 | | otherwise = fxp y 138 | where 139 | y = f x 140 | 141 | isResourceLimitException :: SomeException -> Bool 142 | isResourceLimitException ex = 143 | fromException ex == Just StackOverflow || 144 | fromException ex == Just HeapOverflow || 145 | isTimeout ex || 146 | case fromException ex of 147 | Just (SomeAsyncException ex) -> isResourceLimitException (SomeException ex) 148 | Nothing -> False 149 | where 150 | -- The Timeout type wasn't exported until GHC 8.10, 151 | -- otherwise we could just do: 152 | -- isJust (fromException ex :: Maybe Timeout) 153 | isTimeout (SomeException ex) = 154 | tyConModule (typeRepTyCon (typeOf ex)) == "System.Timeout" 155 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | 3 | packages: 4 | - . 5 | extra-deps: 6 | - twee-lib-2.5 7 | --------------------------------------------------------------------------------