diff --git a/dlist.cabal b/dlist.cabal index a078235..f066aa5 100644 --- a/dlist.cabal +++ b/dlist.cabal @@ -39,10 +39,11 @@ library test-suite test type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: Properties hs-source-dirs: tests build-depends: dlist, base, Cabal, - QuickCheck >= 2.6 && < 2.7 + QuickCheck >= 2.6 && < 2.7, + pqc >= 0.8 && < 0.9 + ghc-options: -threaded -with-rtsopts=-N diff --git a/hpc.sh b/hpc.sh index 44f60ea..2c4d081 100755 --- a/hpc.sh +++ b/hpc.sh @@ -1 +1 @@ -ghc -fhpc --make -O2 -itests tests/Main.hs -o test +ghc -fhpc -threaded -with-rtsopts=-N --make -O2 -itests tests/Main.hs -o test $* diff --git a/tests/Main.hs b/tests/Main.hs index 22f9c53..ec60a88 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,16 +1,114 @@ +{-# OPTIONS_GHC -Wall #-} + module Main (main) where -------------------------------------------------------------------------------- -import Control.Monad (unless) -import System.Exit (exitFailure) +import qualified Prelude as P +import qualified Data.List as P (unfoldr) +import Prelude hiding (head, tail, foldr, replicate) +import Text.Show.Functions () +import Data.Monoid (mconcat) +import Control.Arrow (second) + +import Data.Foldable (foldr) +import Data.Traversable (traverse) -import Properties (run) +import Test.QuickCheck.Parallel + +import Data.DList hiding (concat, map, foldr) -------------------------------------------------------------------------------- +prop_model :: [Int] -> Bool +prop_model x = (toList . fromList $ x) == id x + +prop_empty :: Bool +prop_empty = ([] :: [Int]) == (toList empty :: [Int]) + +prop_singleton :: Int -> Bool +prop_singleton c = [c] == toList (singleton c) + +prop_cons :: Int -> [Int] -> Bool +prop_cons c xs = (c : xs) == toList (cons c (fromList xs)) + +prop_snoc :: [Int] -> Int -> Bool +prop_snoc xs c = (xs ++ [c]) == toList (snoc (fromList xs) c) + +prop_append :: [Int] -> [Int] -> Bool +prop_append xs ys = (xs ++ ys) == toList (append (fromList xs) (fromList ys)) + +prop_concat :: [[Int]] -> Bool +prop_concat zss = (concat zss) == toList (mconcat (map fromList zss)) + +prop_replicate :: Int -> Int -> Bool +prop_replicate n x = (P.replicate n x) == toList (replicate n x) + +prop_head :: [Int] -> Property +prop_head xs = not (null xs) ==> (P.head xs) == head (fromList xs) + +prop_tail :: [Int] -> Property +prop_tail xs = not (null xs) ==> (P.tail xs) == (toList . tail . fromList) xs + +prop_unfoldr :: (Int -> Maybe (Int, Int)) -> Int -> Int -> Property +prop_unfoldr f x n = n >= 0 ==> take n (P.unfoldr f x) + == take n (toList $ unfoldr f x) + +prop_foldr :: (Int -> Int -> Int) -> Int -> [Int] -> Bool +prop_foldr f x xs = foldr f x xs == foldr f x (fromList xs) + +prop_traverse :: (Int -> [Int]) -> [Int] -> Bool +prop_traverse f xs = fmap fromList (traverse f xs) == traverse f (fromList xs) + +prop_map :: (Int -> Int) -> [Int] -> Bool +prop_map f xs = (map f xs) == (toList $ fmap f (fromList xs)) + +prop_map_fusion :: (Int -> Int) -> (a -> Int) -> [a] -> Bool +prop_map_fusion f g xs = (map f . map g $ xs) + == (toList $ fmap f . fmap g $ fromList xs) + +prop_show_read :: [Int] -> Bool +prop_show_read x = (read . show) x == x + +prop_read_show :: [Int] -> Bool +prop_read_show x = (show . f . read) s == s + where + s = "fromList " ++ show x + f :: DList Int -> DList Int + f = id + +-------------------------------------------------------------------------------- + +props :: [(Name, Property)] +props = + [ ("model", property prop_model) + , ("empty", property prop_empty) + , ("singleton", property prop_singleton) + , ("cons", property prop_cons) + , ("snoc", property prop_snoc) + , ("append", property prop_append) + , ("concat", property prop_concat) + , ("replicate", property prop_replicate) + , ("head", property prop_head) + , ("tail", property prop_tail) + , ("unfoldr", property prop_unfoldr) + , ("foldr", property prop_foldr) + , ("traverse", property prop_traverse) + , ("map", property prop_map) + , ("map fusion", property (prop_map_fusion (+1) (+1))) + , ("read . show", property prop_show_read) + , ("show . read", property prop_read_show) + ] + +-------------------------------------------------------------------------------- + +{- +-- Sequential +main :: IO () +main = quickCheck $ conjoin (map (uncurry label) props) +-} + +-- Parallel main :: IO () -main = do - success <- run - unless success exitFailure +main = pRunAllProcessors 100 $ map (second pDet) props diff --git a/tests/Parallel.hs b/tests/Parallel.hs deleted file mode 100644 index 6706657..0000000 --- a/tests/Parallel.hs +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Test.QuickCheck.Parallel --- Copyright : (c) Don Stewart 2006 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : dons@cse.unsw.edu.au --- Stability : experimental --- Portability : non-portable (uses Control.Exception, Control.Concurrent) --- --- A parallel batch driver for running QuickCheck on threaded or SMP systems. --- See the /Example.hs/ file for a complete overview. --- - -module Parallel ( - module Test.QuickCheck, - pRun, - pDet, - pNon - ) where - -import Test.QuickCheck -import Data.List -import Control.Concurrent -import Control.Exception hiding (evaluate) -import System.Random -import System.IO (hFlush,stdout) -import Text.Printf - -type Name = String -type Depth = Int -type Test = (Name, Depth -> IO String) - --- | Run a list of QuickCheck properties in parallel chunks, using --- 'n' Haskell threads (first argument), and test to a depth of 'd' --- (second argument). Compile your application with '-threaded' and run --- with the SMP runtime's '-N4' (or however many OS threads you want to --- donate), for best results. --- --- > import Test.QuickCheck.Parallel --- > --- > do n <- getArgs >>= readIO . head --- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] --- --- Will run 'n' threads over the property list, to depth 1000. --- -pRun :: Int -> Int -> [Test] -> IO () -pRun n depth tests = do - chan <- newChan - ps <- getChanContents chan - work <- newMVar tests - - forM_ [1..n] $ forkIO . thread work chan - - let wait xs i - | i >= n = return () -- done - | otherwise = case xs of - Nothing : xs -> wait xs $! i+1 - Just s : xs -> putStr s >> hFlush stdout >> wait xs i - wait ps 0 - - where - thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () - thread work chan me = loop - where - loop = do - job <- modifyMVar work $ \jobs -> return $ case jobs of - [] -> ([], Nothing) - (j:js) -> (js, Just j) - case job of - Nothing -> writeChan chan Nothing -- done - Just (name,prop) -> do - v <- prop depth - writeChan chan . Just $ printf "%d: %-25s: %s" me name v - loop - - --- | Wrap a property, and run it on a deterministic set of data -pDet :: Testable a => a -> Int -> IO String -pDet a n = mycheck Det defaultConfig - { configMaxTest = n - , configEvery = \n args -> unlines args } a - --- | Wrap a property, and run it on a non-deterministic set of data -pNon :: Testable a => a -> Int -> IO String -pNon a n = mycheck NonDet defaultConfig - { configMaxTest = n - , configEvery = \n args -> unlines args } a - -data Mode = Det | NonDet - ------------------------------------------------------------------------- - -mycheck :: Testable a => Mode -> Config -> a -> IO String -mycheck Det config a = do - let rnd = mkStdGen 99 -- deterministic - mytests config (evaluate a) rnd 0 0 [] - -mycheck NonDet config a = do - rnd <- newStdGen -- different each run - mytests config (evaluate a) rnd 0 0 [] - -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String -mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = do done "OK," ntest stamps - | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps - | otherwise = do - case ok result of - Nothing -> - mytests config gen rnd1 ntest (nfail+1) stamps - Just True -> - mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - return ( "Falsifiable after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 - -done :: String -> Int -> [[String]] -> IO String -done mesg ntest stamps = - return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) - where - table = display - . map entry - . reverse - . sort - . map pairLength - . group - . sort - . filter (not . null) - $ stamps - - display [] = ".\n" - display [x] = " (" ++ x ++ ").\n" - display xs = ".\n" ++ unlines (map (++ ".") xs) - - pairLength xss@(xs:_) = (length xss, xs) - entry (n, xs) = percentage n ntest - ++ " " - ++ concat (intersperse ", " xs) - - percentage n m = show ((100 * n) `div` m) ++ "%" - -forM_ = flip mapM_ diff --git a/tests/Properties.hs b/tests/Properties.hs deleted file mode 100644 index 447c171..0000000 --- a/tests/Properties.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} - -module Properties (run) where - --------------------------------------------------------------------------------- - -import qualified Prelude as P -import qualified Data.List as P (unfoldr) -import Prelude hiding (head, tail, foldr, replicate) -import Text.Show.Functions () -import Data.Monoid (mconcat) - -import Data.Foldable (foldr) -import Data.Traversable (traverse) - -import Test.QuickCheck -import Test.QuickCheck.Test (isSuccess) - -import Data.DList hiding (concat, map, foldr) - --------------------------------------------------------------------------------- - -prop_model :: [Int] -> Bool -prop_model x = (toList . fromList $ x) == id x - -prop_empty :: Bool -prop_empty = ([] :: [Int]) == (toList empty :: [Int]) - -prop_singleton :: Int -> Bool -prop_singleton c = [c] == toList (singleton c) - -prop_cons :: Int -> [Int] -> Bool -prop_cons c xs = (c : xs) == toList (cons c (fromList xs)) - -prop_snoc :: [Int] -> Int -> Bool -prop_snoc xs c = (xs ++ [c]) == toList (snoc (fromList xs) c) - -prop_append :: [Int] -> [Int] -> Bool -prop_append xs ys = (xs ++ ys) == toList (append (fromList xs) (fromList ys)) - -prop_concat :: [[Int]] -> Bool -prop_concat zss = (concat zss) == toList (mconcat (map fromList zss)) - -prop_replicate :: Int -> Int -> Bool -prop_replicate n x = (P.replicate n x) == toList (replicate n x) - -prop_head :: [Int] -> Property -prop_head xs = not (null xs) ==> (P.head xs) == head (fromList xs) - -prop_tail :: [Int] -> Property -prop_tail xs = not (null xs) ==> (P.tail xs) == (toList . tail . fromList) xs - -prop_unfoldr :: (Int -> Maybe (Int, Int)) -> Int -> Int -> Property -prop_unfoldr f x n = n >= 0 ==> take n (P.unfoldr f x) - == take n (toList $ unfoldr f x) - -prop_foldr :: (Int -> Int -> Int) -> Int -> [Int] -> Bool -prop_foldr f x xs = foldr f x xs == foldr f x (fromList xs) - -prop_traverse :: (Int -> [Int]) -> [Int] -> Bool -prop_traverse f xs = fmap fromList (traverse f xs) == traverse f (fromList xs) - -prop_map :: (Int -> Int) -> [Int] -> Bool -prop_map f xs = (map f xs) == (toList $ fmap f (fromList xs)) - -prop_map_fusion :: (Int -> Int) -> (a -> Int) -> [a] -> Bool -prop_map_fusion f g xs = (map f . map g $ xs) - == (toList $ fmap f . fmap g $ fromList xs) - -prop_show_read :: [Int] -> Bool -prop_show_read x = (read . show) x == x - -prop_read_show :: [Int] -> Bool -prop_read_show x = (show . f . read) s == s - where - s = "fromList " ++ show x - f :: DList Int -> DList Int - f = id - --------------------------------------------------------------------------------- - -props :: [Property] -props = - [ label "model" prop_model - , label "empty" prop_empty - , label "singleton" prop_singleton - , label "cons" prop_cons - , label "snoc" prop_snoc - , label "append" prop_append - , label "concat" prop_concat - , label "replicate" prop_replicate - , label "head" prop_head - , label "tail" prop_tail - , label "unfoldr" prop_unfoldr - , label "foldr" prop_foldr - , label "traverse" prop_traverse - , label "map" prop_map - , label "map fusion" (prop_map_fusion (+1) (+1)) - , label "read . show" prop_show_read - , label "show . read" prop_read_show - ] - -run :: IO Bool -run = fmap isSuccess $ quickCheckResult (conjoin props) -