diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014 Omari Norman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Omari Norman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# Quickpull + +Quickpull helps you generate QuickCheck tests with +a minimum of boilerplating. + +For additional information please see the +documentation in the [Quickpull module](lib/Quickpull.hs). + +# License + +Quickpull is licensed under the BSD license; +please see the [LICENSE](LICENSE) file. + +# Author + +Omari Norman, omari@smileystation.com. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bin/quickpull.hs b/bin/quickpull.hs new file mode 100644 --- /dev/null +++ b/bin/quickpull.hs @@ -0,0 +1,33 @@ +module Main where + +import Control.Monad +import System.Environment +import System.Exit +import Quickpull.Files +import Quickpull.Render + +help + :: String + -- ^ Program name + -> String + +help pn = unlines + [ "usage: " ++ pn ++ " DIRECTORY..." + , "Finds each Haskell module in each given directory." + , "Prints to standard output a module containing a list" + , "of all QuickCheck properties in each module." + ] + +runnerModuleName :: String +runnerModuleName = "Decrees" + +main :: IO () +main = do + as <- getArgs + pn <- getProgName + when (as == ["-h"] || as == ["--help"]) $ do + putStr $ help pn + exitSuccess + mds <- fmap concat . mapM allModules $ as + ps <- fmap concat . mapM readAndParse $ mds + putStr $ testModule runnerModuleName ps diff --git a/current-versions.txt b/current-versions.txt new file mode 100644 --- /dev/null +++ b/current-versions.txt @@ -0,0 +1,42 @@ +This package was tested to work with these dependency +versions and compiler version. +These are the default versions fetched by cabal install. +Tested as of: 2014-07-13 15:07:50.828612 UTC +Path to compiler: ghc-7.8.2 +Compiler description: 7.8.2 + +/opt/ghc/7.8.2/lib/ghc-7.8.2/package.conf.d: + Cabal-1.18.1.3 + array-0.5.0.0 + base-4.7.0.0 + bin-package-db-0.0.0.0 + binary-0.7.1.0 + rts-1.0 + bytestring-0.10.4.0 + containers-0.5.5.1 + deepseq-1.3.0.2 + directory-1.2.1.0 + filepath-1.3.0.2 + (ghc-7.8.2) + ghc-prim-0.3.1.0 + (haskell2010-1.1.2.0) + (haskell98-2.0.0.3) + hoopl-3.10.0.1 + hpc-0.6.0.1 + integer-gmp-0.5.1.0 + old-locale-1.0.0.6 + old-time-1.1.0.2 + pretty-1.1.1.1 + process-1.2.0.0 + template-haskell-2.9.0.0 + time-1.4.2 + transformers-0.3.0.0 + unix-2.7.0.1 + +/home/massysett/quickpull/sunlight-922/db: + QuickCheck-2.7.5 + primitive-0.5.3.0 + quickpull-0.2.0.0 + random-1.0.1.1 + tf-random-0.5 + diff --git a/genCabal.hs b/genCabal.hs new file mode 100644 --- /dev/null +++ b/genCabal.hs @@ -0,0 +1,151 @@ +-- Generate Cabal file using the Cartel library. +-- Written for Cartel version 0.10.0.2 + +module Main where + +import qualified Cartel as C + +version :: [Int] +version = [0,2,0,0] + +-- Dependencies are intended to work with GHC 7.4.1. Versions that +-- came with GHC 7.4.1: +-- base-4.5.0.0 +-- directory-1.1.0.2 +-- filepath-1.3.0.0 + +-- Versions that came with GHC 7.8.2: +-- base-4.7.0.0 +-- directory-1.2.1.0 +-- filepath-1.3.0.2 + +-- quickcheck needs to be at least 2.7, as that version has the === +-- combinator. As of 2014-07-05 the oldest version in the 2.7 series +-- that is on Hackage is 2.7.2. + +base :: C.Package +base = C.closedOpen "base" [4,5,0,0] [4,8] + +quickcheck :: C.Package +quickcheck = C.closedOpen "QuickCheck" [2,7,2] [2,8] + +directory :: C.Package +directory = C.closedOpen "directory" [1,1,0,2] [1,3] + +filepath :: C.Package +filepath = C.closedOpen "filepath" [1,3,0,0] [1,4] + +depends :: [C.Package] +depends = + [ base + , quickcheck + , directory + , filepath + ] + +properties :: C.Properties +properties = C.empty + { C.prName = "quickpull" + , C.prVersion = C.Version version + , C.prLicenseFile = "LICENSE" + , C.prCopyright = "Copyright 2014 Omari Norman" + , C.prAuthor = "Omari Norman, omari@smileystation.com" + , C.prMaintainer = "omari@smileystation.com" + , C.prStability = "Experimental" + , C.prHomepage = "http://www.github.com/massysett/quickpull" + , C.prBugReports = "http://www.github.com/massysett/quickpull/issues" + , C.prSynopsis = "Generate Main module with QuickCheck tests" + , C.prCategory = "Testing" + , C.prDescription = + [ "Reads a tree of modules and outputs a module to run all" + , "QuickCheck tests." + , "For more information, please see documentation in the" + , "\"Quickpull\" module." + ] + , C.prExtraSourceFiles = + [ "current-versions.txt" + , "minimum-versions.txt" + , "genCabal.hs" + , "README.md" + ] + } + +ghcOptions :: [String] +ghcOptions = ["-Wall"] + +library + :: [String] + -- ^ Library modules + -> C.Library +library ms = C.Library + [ C.buildDepends depends + , C.defaultLanguage C.Haskell2010 + , C.hsSourceDirs ["lib"] + , C.ghcOptions ghcOptions + , C.LibExposedModules ms + ] + +testSuite :: C.TestSuite +testSuite = C.TestSuite "quickpull-tests" + [ C.TestType C.ExitcodeStdio + , C.TestMainIs "quickpull-tests.hs" + , C.buildDepends depends + , C.otherModules ["Decrees", "Tests"] + , C.ghcOptions ghcOptions + , C.hsSourceDirs ["lib", "tests"] + , C.defaultLanguage C.Haskell2010 + ] + + +executable :: C.Executable +executable = C.Executable "quickpull" + [ C.buildDepends depends + , C.defaultLanguage C.Haskell2010 + , C.hsSourceDirs ["lib", "bin"] + , C.ExeMainIs "quickpull.hs" + , C.ghcOptions ghcOptions + ] + +-- This tests the Gen monad of QuickCheck. Not included in the +-- default tests because it will fail, as Gen is not a true monad. +exeTestGen :: C.Executable +exeTestGen = C.Executable "quickpull-test-gen" + [ C.cif (C.flag "build-test-gen") + [ C.buildDepends depends ] + [ C.buildable False ] + , C.defaultLanguage C.Haskell2010 + , C.ExeMainIs "quickpull-test-gen.hs" + , C.hsSourceDirs ["lib", "quickcheck-tests"] + , C.otherModules ["Decrees", "Tests"] + , C.ghcOptions ghcOptions + ] + +flagTestGen :: C.Flag +flagTestGen = C.empty + { C.flName = "build-test-gen" + , C.flDescription = "Build the quickpull-test-gen executable" + , C.flDefault = False + , C.flManual = True + } + +repo :: C.Repository +repo = C.empty + { C.repoVcs = C.Git + , C.repoKind = C.Head + , C.repoLocation = "https://github.com/massysett/quickpull.git" + } + +cabal :: [String] -> C.Cabal +cabal ms = C.empty + { C.cProperties = properties + , C.cRepositories = [repo] + , C.cLibrary = Just $ library ms + , C.cExecutables = [ executable, exeTestGen ] + , C.cTestSuites = [testSuite] + , C.cFlags = [ flagTestGen ] + } + +main :: IO () +main = do + ms <- C.modules "lib" + C.render "genCabal.hs" $ cabal ms diff --git a/lib/Quickpull.hs b/lib/Quickpull.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull.hs @@ -0,0 +1,140 @@ +-- | Quickpull - a simple testing framework to reduce boilerplating +-- +-- Quickpull is a testing framework that helps you test multiple +-- QuickCheck properties with a minimum of boilerplating and +-- redundancy. It consists of two parts: first, an executable file +-- which reads Haskell modules and extracts properties from them; and +-- second, this library, which runs the tests. +-- +-- The executable, named @quickpull@ by default, is a preprocessor. +-- You have to run this executable to get the QuickCheck properties +-- from your modules. It fetches single properties, which are values +-- that have type @'Testable' a@, as well as trees of properties, +-- which have type 'TestTree'. For example, to get your properties if +-- they are in modules in a directory named @tests@, run this from +-- your project's root directory: +-- +-- > $ quickpull tests +-- +-- The results will be printed to standard output. Inspect this +-- output, then redirect the output to a module named @Decrees@. +-- +-- @quickpull@ does not know or parse Haskell. It simply reads the +-- file and, following a few simple rules, copies the names of +-- properties and trees, along with metadata about them. All single +-- properties must be named beginning with @prop_@, and trees must be +-- named beginning with @proptree_@. The name of the property or tree +-- must be the first thing on the line, not preceded by spaces on the +-- line (which is probably how you write modules anyway if you are +-- using layout.) +-- +-- One problem with this method is that code that is commented out +-- using the block commenting (with braces) will still be read; at +-- present a simple workaround is to comment out blocks of code using +-- per-line commenting instead. +-- +-- @quickpull@ only gets tests from files ending in @.hs@, and the +-- property name must be the very first thing on the line; therefore, +-- literate Haskell files won't work. +-- +-- You then need a program that actually runs your tests. To get +-- started, you need just a short simple program, like this: +-- +-- @ +-- module Main where +-- +-- import Decrees +-- import Quickpull +-- +-- main = defaultMain decrees +-- @ +-- +-- When run, this program will run the tests, print the results to +-- standard output, and exit with an appropriate error code. +-- +-- If your needs are more complicated, study the "Quickpull.Types" and +-- "Quickpull.Runners" modules. For example, you can: +-- +-- * change the arguments you pass to the QuickCheck driver +-- +-- * inspect each 'Decree' separately to change the way the test is +-- run for different 'Decree's +-- +-- * filter the list of 'Decree' so that you run only some tests +-- rather than all of them +-- +-- There is also the "Quickpull.Laws" module, which helps you test +-- common laws, such as the Monad laws and the Monoid laws. +-- +-- Advantages of Quickpull: +-- +-- * reduces boilerplate and frees you from the tedious task of +-- assembling many tests from one module, and of assembling tests from +-- different modules into another module +-- +-- * compiles quickly; no heavyweight dependencies. +-- +-- * No Template Haskell. +-- +-- Disadvantages: +-- +-- * Requires you to run a preprocessor to get the tests +-- +-- * No way to select at runtime which tests to run or the QuickCheck +-- parameters (at least, not out of the box; you could add this.) +-- +-- * The preprocessor is dumb and inelegant. +-- +-- * No support for Smallcheck or HUnit. +-- +-- * Currently no way to test polymorphic properties; you will have to +-- monomorphise these yourself. +-- +-- For examples of usage, see the tests that are bundled with +-- Quickpull in the @tests/@ directory. These tests use Quickpull to +-- test some common laws, such as the Monad and Monoid laws, on types +-- that come in the standard library. There is a similar test for the +-- QuickCheck 'Test.QuickCheck.Gen' monad in the @quickcheck-tests/@ +-- directory; interestingly enough, Gen does not satisfy the monad +-- laws. To compile and run the @tests/@ tests, run cabal with the +-- @--enable-tests@ option; it will produce a binary named +-- @quickpull-tests@. For the @quickcheck-tests/@ directory, run +-- Cabal with the @-fbuild-test-gen@ option; it will produce a binary +-- named @quickpull-test-gen@. +-- +-- To see how to integrate Quickpull into a development workflow, see +-- the Quickpull source on Github at +-- +-- +-- +-- It has a @generate@ script that runs the @quickpull@ binary to +-- generate the appropriate @Decrees@ modules; after that, @cabal@ can +-- be used as usual to build the package, executables, and +-- distribution tarball. That way, although your test suite will need +-- Quickpull listed as a build dependency so the tests will build, +-- your users will not need to do any preprocessing to run the tests. + +module Quickpull + ( -- * Trees of 'Testable' + TestTree + , group + , test + + -- * Test 'Article', 'Meta'data + , ModDesc(..) + , Meta(..) + , Article(..) + , Decree(..) + + -- * Runners + + -- | Basic functions to run tests; for more complex needs, see + -- "Quickpull.Runners". + , quickCheckTree + , defaultMain + , defaultMainWith + ) where + +import Quickpull.Types +import Quickpull.Runners + diff --git a/lib/Quickpull/Files.hs b/lib/Quickpull/Files.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Files.hs @@ -0,0 +1,120 @@ +module Quickpull.Files where + +import Quickpull.Types +import System.Directory +import System.FilePath +import Data.List +import Data.Char +import Data.Ord +import Data.Maybe + +-- | Takes a stack of directories and a directory where reading was +-- started; returns a single path to the relevant directory. + +concatDirs :: FilePath -> [FilePath] -> FilePath +concatDirs st rst = joinPath $ st : reverse rst + +isInterestingFile :: FilePath -> Bool +isInterestingFile p = case p of + [] -> False + x:xs -> isUpper x && ".hs" `isSuffixOf` xs + +isInterestingDir :: FilePath -> Bool +isInterestingDir p = case p of + [] -> False + x:_ -> isUpper x + +-- | Pulls all modules from a given directory. +modsInDirectory + :: [FilePath] + -- ^ Stack of directories. When descending through a tree, add new + -- directories to the head of this list. + + -> FilePath + -- ^ Reading was started in this directory + + -> IO [ModDesc] +modsInDirectory stk strt = do + let path = concatDirs strt stk + filesAndDirs <- fmap (filter (\x -> x /= "." && x /= "..")) + . fmap sort . getDirectoryContents $ concatDirs strt stk + let fullNames = map ((path ++ "/") ++)filesAndDirs + bools <- mapM doesDirectoryExist fullNames + let ps = zip bools filesAndDirs + dirs = filter isInterestingDir + . map snd . filter fst $ ps + files = filter isInterestingFile . map snd + . filter (not . fst) $ ps + mods = map (makeModDesc strt stk) files + readDir dirName = modsInDirectory (dirName : stk) strt + subdirs <- fmap concat . mapM readDir $ dirs + return $ mods ++ subdirs + +-- | Pulls all modules from the given directory. A module is any file +-- that begins with a capital letter and ends in @.hs@. +allModules + :: FilePath + -- ^ Start reading at this directory. This must be a directory; + -- otherwise a runtime error will occur. + + -> IO [ModDesc] + +allModules = modsInDirectory [] + +-- | Pulls all properties from the text of a file. Properties that +-- are 'Testable' must begin with @prop_@. Properties that are a +-- 'TestTree' must begin with @proptree_@. +-- +-- Steps in this computation: +-- +-- * Split text into lines +-- +-- * Add line numbers +-- +-- * Extract all lines that have a word in the first column; keep only +-- this first word and discard the rest of the line +-- +-- * Sort list by this first word, then reverse the list so that the +-- second occurrence of the word is earlier in the list. This way, if +-- there is a type signature followed by a definition, the type +-- signature is discarded in the next step. +-- +-- * use 'nubBy' to remove duplicate words, such as type signatures +-- +-- * sort words by line number order, so they're in original order again +-- +-- * Create 'Qinfo'; here, words that do not start with @prop_@ or +-- @proptree_@ are discarded + +getQuals + :: ModDesc + -> String + -- ^ Module text + -> [(Meta, Qual)] +getQuals d + = mapMaybe mkQ + . sortBy (comparing fst) + . nubBy (\x y -> snd x == snd y) + . reverse + . sortBy (comparing snd) + . mapMaybe getFirstWord + . zip [1..] + . lines + where + mkQ (i, var) + | "prop_" `isPrefixOf` var = Just $ (Meta d i var, QProp) + | "proptree_" `isPrefixOf` var = Just $ (Meta d i var, QTree) + | otherwise = Nothing + getFirstWord (i, s) + | null r = Nothing + | otherwise = Just (i, r) + where + r = takeWhile varIdChar s + varIdChar c = isLower c || isUpper c || isDigit c + || c == '_' || c == '\'' + +-- | Given a 'ModDesc', reads the module from disk and parses it. +readAndParse :: ModDesc -> IO [(Meta, Qual)] +readAndParse d = do + t <- readFile . modPath $ d + return $ getQuals d t diff --git a/lib/Quickpull/Formatting.hs b/lib/Quickpull/Formatting.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Formatting.hs @@ -0,0 +1,12 @@ +module Quickpull.Formatting where + +indentAmt :: Int +indentAmt = 2 + +indent :: Int -> String -> String +indent d s = replicate (d * 2) ' ' ++ s ++ "\n" + +(<+>) :: String -> String -> String +l <+> r + | null l || null r = l ++ r + | otherwise = l ++ " " ++ r diff --git a/lib/Quickpull/Function.hs b/lib/Quickpull/Function.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Function.hs @@ -0,0 +1,16 @@ +-- | Helpers to generate random functions. +module Quickpull.Function where + +import Test.QuickCheck +import Test.QuickCheck.Gen.Unsafe + +-- | Generate a random function. This is simply a duplicate of what's +-- in the QuickCheck 'Arbitrary' instance for functions; having it +-- here saves you from having to define 'Arbitrary' and 'CoArbitrary' +-- instances for your types (which can require either orphan instances +-- or a lot of annoying wrapping and unwrapping.) +function + :: (a -> Gen b -> Gen b) + -> Gen b + -> Gen (a -> b) +function perturb gen = promote (`perturb` gen) diff --git a/lib/Quickpull/Laws.hs b/lib/Quickpull/Laws.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Laws.hs @@ -0,0 +1,291 @@ +-- | Functions to build 'TestTree' that test properties of +-- typeclasses, such as the functor laws, monad laws, and monoid laws. +-- These functions are rough; for example, they do not shrink on +-- failure, they are monomorphic, and they do not show the +-- counterexamples of failing functions. But they are sufficient to +-- help verify the lawfulness of your types. +module Quickpull.Laws where + +import Control.Applicative +import Data.Monoid +import Quickpull.Types +import Test.QuickCheck + +-- | Tests the monad laws: +-- +-- Left identity: +-- +-- > return a >>= f == f a +-- +-- Right identity: +-- +-- > m >>= return == m +-- +-- Associativity: +-- +-- > (m >>= f) >>= g == m >>= (\x -> f x >>= g) + +monad + :: (Eq b, Show b, Monad m) + => Gen (m Int) + -- ^ Generates a computation in the monad. + + -> Gen (Int -> m Int) + -- ^ Generates a function that, when applied to an Int, returns a + -- computation in the monad. + + -> Gen (m Int -> b) + -- ^ Generates a function that runs a computation in the monad. + + -> TestTree + +monad genK genF genU = group "monad laws" + [ test "left identity" monadLeftIdentity + , test "right identity" monadRightIdentity + , test "associativity" monadAssociativity + ] + where + + monadLeftIdentity = do + i <- arbitrary + f <- genF + u <- genU + return $ (u (return i >>= f)) === u (f i) + + monadRightIdentity = do + m <- genK + u <- genU + return $ (u (m >>= return)) === u m + + monadAssociativity = do + m <- genK + f <- genF + g <- genF + u <- genU + return $ (u ((m >>= f) >>= g)) === (u (m >>= (\x -> f x >>= g))) + +-- | Tests the functor laws: +-- +-- > fmap id == id +-- +-- > fmap (f . g) == fmap f . fmap g + +functor + :: (Eq b, Show b, Functor f) + => Gen (f Int) + -- ^ Generates a computation in the functor. + + -> Gen (f Int -> b) + -- ^ Generates a computation that unwraps the functor. + + -> TestTree +functor genK genU = group "functor laws" + [ test "identity" tIdentity + , test "composition" tComposition + ] + where + tIdentity = do + k <- genK + u <- genU + return $ (u (fmap id k)) === (u (id k)) + + tComposition = do + k <- genK + u <- genU + f <- arbitrary + let _types = f :: Int -> Int + g <- arbitrary + return $ (u (fmap (f . g) k)) === (u ((fmap f . fmap g) k)) + +-- | Tests the Applicative laws: +-- +-- * identity: +-- +-- > pure id <*> v == v +-- +-- * composition: +-- +-- > pure (.) <*> u <*> v <*> w == u <*> (v <*> w) +-- +-- * homomorphism: +-- +-- > pure f <*> pure x = pure (f x) +-- +-- * interchange: +-- +-- > u <*> pure y = pure ($ y) <*> u + + +applicative + :: (Eq b, Show b, Applicative f) + => Gen (f Int) + -- ^ Generates a computation in the Applicative. + -> Gen (f (Int -> Int)) + -- ^ Generates a function in the Applicative. + -> Gen (f Int -> b) + -- ^ Generates an unwrapping function. + -> TestTree +applicative gK gF gU = group "applicative laws" + [ test "identity" tIdentity + , test "composition" tComposition + , test "homomorphism" tHomomorphism + , test "interchange" tInterchange + ] + where + tIdentity = do + u <- gU + v <- gK + return $ (u (pure id <*> v)) === (u v) + + tComposition = do + u <- gF + v <- gF + w <- gK + r <- gU + return $ (r (pure (.) <*> u <*> v <*> w)) === + (r (u <*> (v <*> w))) + + tHomomorphism = do + f <- arbitrary + let _types = f :: Int -> Int + x <- arbitrary + u <- gU + return $ (u (pure f <*> pure x)) === + (u (pure (f x))) + + tInterchange = do + r <- gU + u <- gF + y <- arbitrary + return $ (r (u <*> pure y)) === + (r (pure ($ y) <*> u)) + +-- | Tests the monoid laws: +-- +-- > mappend mempty x = x +-- +-- > mappend x mempty = x +-- +-- > mappend x (mappend y z) = mappend (mappend x y) z +-- +-- > mconcat = foldr mappend mempty +monoid + :: (Eq b, Show b, Monoid a) + => Gen a + -- ^ Generates monoid values + -> Gen (a -> b) + -- ^ Generates unwrappers + -> TestTree +monoid gV gU = group "monoid laws" + [ test "left identity" tLeft + , test "right identity" tRight + , test "associativity" tAssociative + , test "mconcat = foldr" tFoldr + ] + where + + tLeft = do + x <- gV + u <- gU + return $ (u (mappend mempty x)) === (u x) + + tRight = do + x <- gV + u <- gU + return $ (u (mappend x mempty)) === (u x) + + tAssociative = do + x <- gV + y <- gV + z <- gV + u <- gU + return $ (u (mappend x (mappend y z))) === + (u (mappend (mappend x y) z)) + + tFoldr = do + ls <- listOf gV + u <- gU + return $ (u (mconcat ls)) === + (u (foldr mappend mempty ls)) + +-- | Tests whether a particular operation is associative, that is: +-- +-- > a `f` (b `f` c) == (a `f` b) `f` c +associative + :: (Eq b, Show b) + => Gen (a -> a -> a) + -- ^ Generates an associative operation + -> Gen (a -> b) + -- ^ Generates unwrappers + -> Gen a + -- ^ Generates values + -> Gen Property +associative gF gU gV = do + f <- gF + u <- gU + a <- gV + b <- gV + c <- gV + return $ (u (a `f` (b `f` c))) === + (u ((a `f` b) `f` c)) + +-- | Tests whether a particular operation is commutative, that is: +-- +-- > a `f` b == b `f` a +commutative + :: (Eq b, Show b) + => Gen (a -> a -> a) + -- ^ Generates a commutative operation + -> Gen (a -> b) + -- ^ Generates unwrappers + -> Gen a + -- ^ Generates values + -> Gen Property +commutative gF gU gV = do + f <- gF + u <- gU + a <- gV + b <- gV + return $ (u (a `f` b)) === (u (b `f` a)) + +-- | Tests whether a particular value is the left identity, that is: +-- +-- > z `f` a == a +leftIdentity + :: (Eq b, Show b) + => Gen (a -> a -> a) + -- ^ Generates the operation to test + -> Gen (a -> b) + -- ^ Generates unwrappers + -> Gen a + -- ^ Generates identity values + -> Gen a + -- ^ Generates right-hand side values + -> Gen Property +leftIdentity gF gU gZ gR = do + f <- gF + u <- gU + z <- gZ + r <- gR + return $ u (z `f` r) === u r + +-- | Tests whether a particular value is the right identity, that is: +-- +-- > a `f` z == a +rightIdentity + :: (Eq b, Show b) + => Gen (a -> a -> a) + -- ^ Generates the operation to test + -> Gen (a -> b) + -- ^ Generates unwrappers + -> Gen a + -- ^ Generates identity values + -> Gen a + -- ^ Generates left-hand side values + -> Gen Property +rightIdentity gF gU gZ gL = do + f <- gF + u <- gU + z <- gZ + l <- gL + return $ u (l `f` z) === u l diff --git a/lib/Quickpull/Render.hs b/lib/Quickpull/Render.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Render.hs @@ -0,0 +1,77 @@ +module Quickpull.Render where + +import Quickpull.Types +import Quickpull.Formatting +import Data.List +import Data.Ord + +metaQual + :: Char + -- ^ Leader character + + -> (Meta, Qual) + -> String + +metaQual ldr (m, q) = indent 1 $ [ldr] <+> "Decree (" <+> + show m <+> ")" <+> "(" <+> i <+> ")" + where + kind = case q of + QTree -> "Multi" + QProp -> "Single" + i = kind <+> qualName + qualName = (concat . intersperse "." . modName . modDesc $ m) + ++ "." ++ qName m + +metaQuals :: [(Meta, Qual)] -> String +metaQuals ls = case ls of + [] -> indent 1 "[]" + x:xs -> metaQual '[' x ++ concatMap (metaQual ',') xs + ++ indent 1 "]" + +imports :: [ModDesc] -> String +imports = concatMap mkImport . nub . sortBy (comparing modName) + where + mkImport m = "import qualified " ++ + (concat . intersperse "." . modName $ m) ++ "\n" + +-- | Summarizes a Meta in a single line. +metaLine :: Meta -> String +metaLine m = qName m <+> "from file" <+> (modPath . modDesc $ m) + <+> "at line" <+> show (linenum m) ++ "\n" + +topComments :: String +topComments = unlines + [ "-- | This module generated by the Quickpull package." + , "-- Quickpull is available at:" + , "-- " + , "" + ] + +testModule + :: String + -- ^ Name to use for module + -> [(Meta, Qual)] + -> String +testModule name ls = topComments ++ rest + where + rest = concat . intersperse "\n" $ + [ "module" <+> name <+> "where\n" + , "import Quickpull" + , imports . map (modDesc . fst) $ ls + , unlines + [ "decrees :: [Decree]" + , "decrees =" + ] + , metaQuals ls + ] + +summary :: Summary -> String +summary s = unlines + [ "success: " ++ show (success s) + , "gave up: " ++ show (gaveUp s) + , "failure: " ++ show (failure s) + , "no expected failure: " ++ show (noExpectedFailure s) + , "total: " ++ show + (success s + gaveUp s + failure s + + noExpectedFailure s) + ] diff --git a/lib/Quickpull/Runners.hs b/lib/Quickpull/Runners.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Runners.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE RankNTypes #-} +-- | Running tests. To check a 'TestTree' in a REPL, use +-- 'quickCheckTree'; to check a QuickCheck 'Testable', just use +-- 'Test.QuickCheck.quickCheck' and the similar functions in +-- "Test.QuickCheck". The other functions in this module will be more +-- useful for checking from within a compiled test program. +-- +-- The QuickCheck docs in "Test.QuickCheck" contain warnings about how +-- type defaulting in GHCi can cause types to silently default to +-- @()@; all those warnings also apply to use of the functions in this +-- module. Although QuickCheck has some Template Haskell to help with +-- this, Quickpull currently does not. You don't have to worry about +-- this in non-interactive use, as the defaulting rules are more +-- strict and, with warnings on, GHC will warn you when it defaults a +-- type. +module Quickpull.Runners + ( -- * Testing 'TestTree' + quickCheckTree + , treeWithResult + + -- * Testing 'Decree's + , decreeWithResult + , seeDecree + + -- * Default main functions + , defaultMain + , defaultMainWith + + -- * Summarizing + , summarize + , exitCode + ) where + +import Test.QuickCheck + ( Testable, Result(..), quickCheckResult, quickCheckWithResult, + Args ) +import Quickpull.Types +import Quickpull.Formatting +import Quickpull.Render +import Data.List (foldl') +import System.Exit +import Control.Applicative + +-- | Checks a 'TestTree' and prints the result to standard output in +-- addition to returning it as a list of 'Result'. Each 'Decree' +-- returns a list of 'Result' (a 'Single' returns a single 'Result', +-- while a 'Multi' returns a 'Result' for each test in the tree.) +treeWithResult + :: (forall a. Testable a => a -> IO Result) + -> TestTree + -> IO [Result] +treeWithResult run = go 0 + where + go lvl (TestTree l n) = do + putStr . indent lvl $ l + case n of + Group tt -> fmap concat . mapM (go (succ lvl)) $ tt + Test t -> do + putStr (replicate (indentAmt * (succ lvl)) ' ') + fmap (:[]) $ run t + +-- | Checks a 'TestTree' and prints the result to standard output. +-- Intended for use in a REPL; however, the QuickCheck docs in +-- "Test.QuickCheck" contain warnings about how type defaulting in +-- GHCi can cause types to silently default to @()@; all those +-- warnings also apply to use of this function. +quickCheckTree :: TestTree -> IO () +quickCheckTree t = do + _ <- treeWithResult quickCheckResult t + return () + +-- | Tests a 'Decree' and prints the result to standard output in +-- addition to returning a list of 'Result'. Each 'Decree' returns a +-- list of 'Result' (a 'Single' returns a single 'Result', while a +-- 'Multi' returns a 'Result' for each test in the tree.) +decreeWithResult + :: (forall a. Testable a => a -> IO Result) + -> Decree + -> IO [Result] +decreeWithResult run (Decree m i) = do + putStr . metaLine $ m + case i of + Single a -> fmap (:[]) . run $ a + Multi t -> treeWithResult run t + + +-- | Tallies up the 'Result's. +summarize :: [Result] -> Summary +summarize = foldl' f (Summary 0 0 0 0) + where + f s r = case r of + Success {} -> s { success = succ (success s) } + GaveUp {} -> s { gaveUp = succ (gaveUp s) } + Failure {} -> s { failure = succ (failure s) } + NoExpectedFailure {} -> s + { noExpectedFailure = succ (noExpectedFailure s) } + +-- | Exit successfully if there were no failures, give-ups, or +-- no-expected-failures; otherwise, exit unsuccessfully. +exitCode :: Summary -> ExitCode +exitCode s + | gaveUp s == 0 && failure s == 0 && + noExpectedFailure s == 0 = ExitSuccess + | otherwise = ExitFailure 1 + +-- | Tests each 'Decree' using a custom function that you specify; +-- this allows you to vary the test depending on what's in the +-- 'Decree'. Each 'Decree' returns a list of 'Result' (a 'Single' +-- returns a single 'Result', while a 'Multi' returns a 'Result' for +-- each test in the tree.) The tests are printed to standard output +-- as they run, in addition to returning the 'Result'. +seeDecree + :: (Decree -> forall a. Testable a => a -> IO Result) + -> [Decree] + -> IO [[Result]] +seeDecree f ds = mapM g ds + where + g d = decreeWithResult (f d) d <* putStrLn "" + +testDecrees + :: (Decree -> forall a. Testable a => a -> IO Result) + -> [Decree] + -> IO () +testDecrees f ds = do + rs <- fmap concat $ seeDecree f ds + let s = summarize rs + c = exitCode s + putStr $ summary s + exitWith c + +-- | Tests each 'Decree' and prints the results to standard output. +-- Exits successfully if all tests succeeded; otherwise, exits +-- unsuccessfully. +-- +-- Not recommended for REPL use as this function will either kill your +-- REPL when it's done or, in the case of recent GHC versions, issue +-- an exception. +defaultMain :: [Decree] -> IO () +defaultMain = testDecrees (const quickCheckResult) + +-- | Like 'defaultMain' but allows you to pass arguments to the +-- QuickCheck driver. +-- +-- Not recommended for REPL use as this function will either kill your +-- REPL when it's done or, in the case of recent GHC versions, issue +-- an exception. +defaultMainWith :: Args -> [Decree] -> IO () +defaultMainWith a = testDecrees (const (quickCheckWithResult a)) diff --git a/lib/Quickpull/Types.hs b/lib/Quickpull/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Quickpull/Types.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Quickpull.Types where + +import Quickpull.Formatting +import Test.QuickCheck +import System.FilePath + +-- | A tree of tests. This allows you to group tests for convenient +-- display; it also allows you to write computations that return +-- entire groups of tests. + +data TestTree = TestTree + { label :: String + , payload :: Node + } + +instance Show TestTree where + show = go 0 + where + go d (TestTree s n) = case n of + Group ts -> indent d ("group: " ++ s) + ++ concatMap (go (d + 1)) ts + Test _ -> indent d ("test: " ++ s) + +data Node + = Group [TestTree] + -- ^ A group of tests. Contains a list of 'TestTree', each of which + -- might be a 'Test' or another 'Group'. + + | forall a. Testable a => Test a + -- ^ A QuickCheck test to run. + +-- | A single property or tree to test. +data Article + = forall a. Testable a => Single a + | Multi TestTree + +-- | Metadata about a particular test or group. +data Meta = Meta + { modDesc :: ModDesc + -- ^ Name of file providing this test or group. + + , linenum :: Int + -- ^ Line number of the test or group. + + , qName :: String + -- ^ The name of the test or group, such as @prop_mytest@ or + -- @proptree_mytest@. + + } deriving (Eq, Ord, Show) + +-- | Description of a single property or tree to test from a file. +-- Unlike 'Item', this does not contain the actual item; this is for +-- use when parsing a test input module. +data Qual= QTree | QProp + deriving (Eq, Ord, Show) + + +-- | Description of a module. +data ModDesc = ModDesc + { modPath :: String + -- ^ Path to the module + + , modName :: [String] + -- ^ Each part of the hierarchical name + } deriving (Eq, Ord, Show) + +-- | Creates a 'ModDesc'. +makeModDesc + :: FilePath + -- ^ Reading was started in this directory + + -> [FilePath] + -- ^ Directory stack + + -> FilePath + -- ^ Name of specific file + + -> ModDesc + +makeModDesc strt ds fln = ModDesc + (joinPath $ strt : reverse ds ++ [fln]) + (reverse ds ++ [takeWhile (/= '.') fln]) + + +-- | Specifies a single item to test, along with metadata about that +-- item. +data Decree = Decree + { meta :: Meta + , item :: Article + } + +-- | Summary of all QuickCheck results. +data Summary = Summary + { success :: !Int + , gaveUp :: !Int + , failure :: !Int + , noExpectedFailure :: !Int + } + + +-- | Create a new 'Group' of tests. +group + :: String + -- ^ Group name; a string with no trailing newline. + + -> [TestTree] + -> TestTree +group n ts = TestTree n (Group ts) + +-- | Create a new 'Test'. +test + :: Testable a + + => String + -- ^ Test name; a string with no trailing newline. + + -> a + -> TestTree +test n t = TestTree n (Test t) + diff --git a/minimum-versions.txt b/minimum-versions.txt new file mode 100644 --- /dev/null +++ b/minimum-versions.txt @@ -0,0 +1,42 @@ +This package was tested to work with these dependency +versions and compiler version. +These are the minimum versions given in the .cabal file. +Tested as of: 2014-07-13 15:07:50.828612 UTC +Path to compiler: ghc-7.4.1 +Compiler description: 7.4.1 + +/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d: + Cabal-1.14.0 + array-0.4.0.0 + base-4.5.0.0 + bin-package-db-0.0.0.0 + binary-0.5.1.0 + bytestring-0.9.2.1 + containers-0.4.2.1 + deepseq-1.3.0.0 + directory-1.1.0.2 + extensible-exceptions-0.1.1.4 + filepath-1.3.0.0 + (ghc-7.4.1) + ghc-prim-0.2.0.0 + (haskell2010-1.1.0.1) + (haskell98-2.0.0.1) + hoopl-3.8.7.3 + hpc-0.5.1.1 + integer-gmp-0.4.0.0 + old-locale-1.0.0.4 + old-time-1.1.0.0 + pretty-1.1.1.0 + process-1.1.0.1 + rts-1.0 + template-haskell-2.7.0.0 + time-1.4 + unix-2.5.1.0 + +/home/massysett/quickpull/sunlight-922/db: + QuickCheck-2.7.2 + primitive-0.5.3.0 + quickpull-0.2.0.0 + random-1.0.1.1 + tf-random-0.5 + diff --git a/quickcheck-tests/Decrees.hs b/quickcheck-tests/Decrees.hs new file mode 100644 --- /dev/null +++ b/quickcheck-tests/Decrees.hs @@ -0,0 +1,16 @@ +-- | This module generated by the Quickpull package. +-- Quickpull is available at: +-- + +module Decrees where + +import Quickpull +import qualified Tests + +decrees :: [Decree] +decrees = + + [ Decree ( Meta {modDesc = ModDesc {modPath = "quickcheck-tests/Tests.hs", modName = ["Tests"]}, linenum = 41, qName = "proptree_quickcheckGenMonadLaws"} ) ( Multi Tests.proptree_quickcheckGenMonadLaws ) + , Decree ( Meta {modDesc = ModDesc {modPath = "quickcheck-tests/Tests.hs", modName = ["Tests"]}, linenum = 44, qName = "proptree_quickcheckGenFunctorLaws"} ) ( Multi Tests.proptree_quickcheckGenFunctorLaws ) + , Decree ( Meta {modDesc = ModDesc {modPath = "quickcheck-tests/Tests.hs", modName = ["Tests"]}, linenum = 47, qName = "proptree_quickcheckGenApplicativeLaws"} ) ( Multi Tests.proptree_quickcheckGenApplicativeLaws ) + ] diff --git a/quickcheck-tests/Tests.hs b/quickcheck-tests/Tests.hs new file mode 100644 --- /dev/null +++ b/quickcheck-tests/Tests.hs @@ -0,0 +1,48 @@ +-- | Example tests on the QuickCheck 'Gen' monad. +-- +-- The tests 'proptree_quickcheckGenMonadLaws' and +-- 'proptree_quickcheckGenApplicativeLaws' will fail, because 'Gen' +-- does not obey the monad laws if you interpret them strictly, see: +-- +-- +-- +-- This module is useful as a more intricate example of the use of +-- Quickpull, as well as an example of tests that fail (unlike the +-- tests included in the test suite, as these should always pass.) +module Tests where + +import Quickpull +import Quickpull.Function +import Quickpull.Laws +import Test.QuickCheck +import Test.QuickCheck.Gen + +genGen :: Gen (Gen Int) +genGen = do + f <- function coarbitraryShow arbitrary + return $ MkGen (curry f) + +genFGen :: Gen (Int -> Gen Int) +genFGen = do + i <- arbitrary :: Gen Int + gi <- genGen + return $ \j -> variant i . variant j $ gi + +genRunner :: Gen (Gen Int -> Int) +genRunner = MkGen $ \g s -> + \(MkGen f) -> f g s + +genFunction :: Gen (Gen (Int -> Int)) +genFunction = do + i <- arbitrary :: Gen Int + return $ variant i arbitrary + +proptree_quickcheckGenMonadLaws :: TestTree +proptree_quickcheckGenMonadLaws = monad genGen genFGen genRunner + +proptree_quickcheckGenFunctorLaws :: TestTree +proptree_quickcheckGenFunctorLaws = functor genGen genRunner + +proptree_quickcheckGenApplicativeLaws :: TestTree +proptree_quickcheckGenApplicativeLaws = + applicative genGen genFunction genRunner diff --git a/quickcheck-tests/quickpull-test-gen.hs b/quickcheck-tests/quickpull-test-gen.hs new file mode 100644 --- /dev/null +++ b/quickcheck-tests/quickpull-test-gen.hs @@ -0,0 +1,7 @@ +module Main where + +import Quickpull +import Decrees + +main :: IO () +main = defaultMain decrees diff --git a/quickpull.cabal b/quickpull.cabal new file mode 100644 --- /dev/null +++ b/quickpull.cabal @@ -0,0 +1,113 @@ +-- This Cabal file generated using the Cartel library. +-- Cartel is available at: +-- http://www.github.com/massysett/cartel +-- +-- Script name used to generate: genCabal.hs +-- Generated on: 2014-07-13 11:14:43.265661 EDT +-- Cartel library version: 0.10.0.2 +name: quickpull +version: 0.2.0.0 +cabal-version: >= 1.14 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright 2014 Omari Norman +author: Omari Norman, omari@smileystation.com +maintainer: omari@smileystation.com +stability: Experimental +homepage: http://www.github.com/massysett/quickpull +bug-reports: http://www.github.com/massysett/quickpull/issues +synopsis: Generate Main module with QuickCheck tests +description: + Reads a tree of modules and outputs a module to run all + QuickCheck tests. + For more information, please see documentation in the + "Quickpull" module. +category: Testing +extra-source-files: + current-versions.txt + , minimum-versions.txt + , genCabal.hs + , README.md + +source-repository head + type: git + location: https://github.com/massysett/quickpull.git + +Flag build-test-gen + Description: Build the quickpull-test-gen executable + Default: False + Manual: True + +Library + build-depends: + base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) + , QuickCheck ((> 2.7.2 || == 2.7.2) && < 2.8) + , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) + , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) + default-language: Haskell2010 + hs-source-dirs: + lib + ghc-options: + -Wall + exposed-modules: + Quickpull + , Quickpull.Files + , Quickpull.Formatting + , Quickpull.Function + , Quickpull.Laws + , Quickpull.Render + , Quickpull.Runners + , Quickpull.Types + +Executable quickpull + build-depends: + base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) + , QuickCheck ((> 2.7.2 || == 2.7.2) && < 2.8) + , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) + , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) + default-language: Haskell2010 + hs-source-dirs: + lib + , bin + main-is: quickpull.hs + ghc-options: + -Wall + +Executable quickpull-test-gen + if flag(build-test-gen) + build-depends: + base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) + , QuickCheck ((> 2.7.2 || == 2.7.2) && < 2.8) + , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) + , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) + else + buildable: False + default-language: Haskell2010 + main-is: quickpull-test-gen.hs + hs-source-dirs: + lib + , quickcheck-tests + other-modules: + Decrees + , Tests + ghc-options: + -Wall + +Test-Suite quickpull-tests + type: exitcode-stdio-1.0 + main-is: quickpull-tests.hs + build-depends: + base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8) + , QuickCheck ((> 2.7.2 || == 2.7.2) && < 2.8) + , directory ((> 1.1.0.2 || == 1.1.0.2) && < 1.3) + , filepath ((> 1.3.0.0 || == 1.3.0.0) && < 1.4) + other-modules: + Decrees + , Tests + ghc-options: + -Wall + hs-source-dirs: + lib + , tests + default-language: Haskell2010 diff --git a/tests/Decrees.hs b/tests/Decrees.hs new file mode 100644 --- /dev/null +++ b/tests/Decrees.hs @@ -0,0 +1,21 @@ +-- | This module generated by the Quickpull package. +-- Quickpull is available at: +-- + +module Decrees where + +import Quickpull +import qualified Tests + +decrees :: [Decree] +decrees = + + [ Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 11, qName = "proptree_maybeMonadLaws"} ) ( Multi Tests.proptree_maybeMonadLaws ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 14, qName = "proptree_maybeFunctorLaws"} ) ( Multi Tests.proptree_maybeFunctorLaws ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 17, qName = "proptree_maybeApplicativeLaws"} ) ( Multi Tests.proptree_maybeApplicativeLaws ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 21, qName = "proptree_listMonoidLaws"} ) ( Multi Tests.proptree_listMonoidLaws ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 25, qName = "prop_addIsAssociative"} ) ( Single Tests.prop_addIsAssociative ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 29, qName = "prop_addIsCommutative"} ) ( Single Tests.prop_addIsCommutative ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 33, qName = "prop_zeroAddLeftIdentity"} ) ( Single Tests.prop_zeroAddLeftIdentity ) + , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Tests.hs", modName = ["Tests"]}, linenum = 38, qName = "prop_oneDivideRightIdentity"} ) ( Single Tests.prop_oneDivideRightIdentity ) + ] diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,40 @@ +module Tests where + +import Quickpull +import Quickpull.Laws +import Test.QuickCheck + +maybefy :: Maybe Int -> Maybe Int +maybefy = id + +proptree_maybeMonadLaws :: TestTree +proptree_maybeMonadLaws = monad arbitrary arbitrary (return maybefy) + +proptree_maybeFunctorLaws :: TestTree +proptree_maybeFunctorLaws = functor arbitrary (return maybefy) + +proptree_maybeApplicativeLaws :: TestTree +proptree_maybeApplicativeLaws = + applicative arbitrary arbitrary (return maybefy) + +proptree_listMonoidLaws :: TestTree +proptree_listMonoidLaws = + monoid (listOf arbitrary) (return (id :: [Int] -> [Int])) + +prop_addIsAssociative :: Gen Property +prop_addIsAssociative = + associative (return (+)) (return (id :: Int -> Int)) arbitrary + +prop_addIsCommutative :: Gen Property +prop_addIsCommutative = + commutative (return (+)) (return (id :: Int -> Int)) arbitrary + +prop_zeroAddLeftIdentity :: Gen Property +prop_zeroAddLeftIdentity = + leftIdentity (return (+)) (return (id :: Int -> Int)) + (return 0) arbitrary + +prop_oneDivideRightIdentity :: Gen Property +prop_oneDivideRightIdentity = + rightIdentity (return div) (return (id :: Int -> Int)) + (return 1) arbitrary diff --git a/tests/quickpull-tests.hs b/tests/quickpull-tests.hs new file mode 100644 --- /dev/null +++ b/tests/quickpull-tests.hs @@ -0,0 +1,7 @@ +module Main where + +import Quickpull +import Decrees + +main :: IO () +main = defaultMain decrees