diff --git a/Extra.cabal b/Extra.cabal --- a/Extra.cabal +++ b/Extra.cabal @@ -1,13 +1,13 @@ Name: Extra -Version: 1.33 +Version: 1.42 License: BSD3 License-File: COPYING Author: David Fox Category: Unclassified Description: A hodge-podge of functions and modules that do not have a better home Maintainer: David Fox -Homepage: http://src.seereason.com/ghc6102/haskell-extra/ -Build-Depends: base >= 3 && < 4, unix, regex-compat, time >= 1.1, Unixutils >= 1.10 , mtl, network, pretty, directory, bytestring, process, containers, old-time, old-locale, QuickCheck < 2, HUnit, random, filepath +Homepage: http://src.seereason.com/haskell-extra +Build-Depends: base < 5, unix, regex-compat, time >= 1.1, Unixutils >= 1.32 , mtl, network, pretty, directory, bytestring, process, containers, old-time, old-locale, QuickCheck >= 2 && < 3, HUnit, random, filepath, zlib, bzlib Synopsis: A grab bag of modules. ghc-options: -O2 -W C-Sources: cbits/gwinsz.c @@ -16,7 +16,8 @@ Exposed-modules: Extra.Bool, Extra.Either, Extra.Exit, Extra.Files, Extra.GPGSign,Extra.List, Extra.HughesPJ, Extra.Lock, Extra.Misc, Extra.Net, Extra.SSH, - Extra.Time, Extra.Terminal, Extra.CIO, Extra.TIO, Extra.IO, Extra.URI, Test.QUnit, Test.QuickCheck.Properties + Extra.Time, Extra.Terminal, Extra.CIO, Extra.TIO, Extra.IO, Extra.URI, Extra.URIQuery, + Test.QUnit, Test.QuickCheck.Properties, Extra.IOThread Build-Type: Simple -- For more complex build options see: diff --git a/Extra/CIO.hs b/Extra/CIO.hs --- a/Extra/CIO.hs +++ b/Extra/CIO.hs @@ -5,6 +5,12 @@ -- There is an instance for the regular IO monad which doesn't use any -- of these features, to allow functions which do not use the TIO -- monad call functions in the Debian library. +-- +-- NOTE: a copy of this library is in the Extra library as +-- well. Please update both locations. +-- +-- This code is provided for backwards compatibility, I don't +-- endorse its use in new projects. module Extra.CIO ( -- * The CIO class CIO(..) @@ -56,6 +62,12 @@ , vHBOL , vBOL , vEBOL + + , hColor + , blue + , green + , red + , magenta ) where import Prelude hiding (putStr, putChar, putStrLn) @@ -80,7 +92,7 @@ -- |Modify the current output style. setStyle :: (TStyle -> TStyle) -> m a -> m a -- |Implementation of try for this monad - tryCIO :: m a -> m (Either Exception a) + tryCIO :: m a -> m (Either SomeException a) -- |A record used to hold the output style information for a task. -- This The prefixes that will appear at the beginning of each line, diff --git a/Extra/Files.hs b/Extra/Files.hs --- a/Extra/Files.hs +++ b/Extra/Files.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- |Some extra operations on files. The functions here generally -- return (Right ()) on success, Left [messages] on failure, and throw -- an exception when a failure leaves things in an inconsistant state. @@ -21,19 +22,18 @@ , replaceFile ) where +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.BZip as BZip import Control.Exception hiding (catch) import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Data.ByteString.Lazy as B import Data.List import Data.Maybe import Extra.Misc import System.Unix.Directory -import System.Unix.Process import System.Directory -import System.IO import System.IO.Error hiding (try, catch) import System.Posix.Files -import System.Posix.Unistd -- | Return the list of subdirectories, omitting . and .. and ignoring -- symbolic links. @@ -107,7 +107,7 @@ case deleted of Right () -> try (rename old new) >>= - return . either (\ e -> Left ["Couldn't rename " ++ old ++ " -> " ++ new ++ ": " ++ show e]) (\ _ -> Right ()) + return . either (\ (e :: SomeException) -> Left ["Couldn't rename " ++ old ++ " -> " ++ new ++ ": " ++ show e]) (\ _ -> Right ()) x -> return x -- |Change a file's name if it exists. @@ -128,26 +128,26 @@ do status <- getSymbolicLinkStatus path -- To do: should we remove the directory contents? let rm = if isDirectory status then removeDirectory else removeLink - try (rm path) >>= return . either (\ e -> Left ["Couldn't remove " ++ path ++ ": " ++ show e]) (const . Right $ ()) + try (rm path) >>= return . either (\ (e :: SomeException) -> Left ["Couldn't remove " ++ path ++ ": " ++ show e]) (const . Right $ ()) -- |Create or update gzipped and bzip2-ed versions of a file. zipFile :: FilePath -> IO (Either [String] ()) zipFile path = - do let commands = ["gzip < '" ++ path ++ "' > '" ++ path ++ ".gz'", - "bzip2 < '" ++ path ++ "' > '" ++ path ++ ".bz2'"] - forceRemoveLink (path ++ ".gz") - forceRemoveLink (path ++ ".bz2") - results <- mapM (\ cmd -> lazyCommand cmd B.empty) commands - case filter (/= ExitSuccess) (concat (map exitCodeOnly results)) of - [] -> return $ Right () - _ -> return (Left ["Failure writing and zipping " ++ path ++ ": " ++ - concat (map writeMessage (zip commands results))]) + try (do forceRemoveLink gz + forceRemoveLink bz2 + B.readFile path >>= B.writeFile gz . {- t1 . -} GZip.compress + B.readFile path >>= B.writeFile bz2 . {- t2 . -} BZip.compress) >>= + return . either (\ (e :: SomeException) -> Left ["Failure writing and zipping " ++ path, show e]) Right where - writeMessage (command, output) = - case exitCodeOnly output of - (ExitFailure n : _) -> - command ++ " -> " ++ show n ++ ":\n " ++ B.unpack (stderrOnly output) - _ -> "" + gz = path ++ ".gz" + bz2 = path ++ ".bz2" + --t1 s = trace ("Size of " ++ gz ++ " text: " ++ show (L.length s)) s + --t2 s = trace ("Size of " ++ bz2 ++ " text: " ++ show (L.length s)) s + --writeMessage (command, output) = + -- case exitCodeOnly output of + -- (ExitFailure n : _) -> + -- command ++ " -> " ++ show n ++ ":\n " ++ L.unpack (stderrOnly output) + -- _ -> "" -- |like removeLink, but does not fail if link did not exist forceRemoveLink :: FilePath -> IO () @@ -159,9 +159,10 @@ backupFile path >>= either (\ e -> return (Left ["Failure renaming " ++ path ++ " -> " ++ path ++ "~: " ++ show e])) (\ _ -> try (B.writeFile path text) >>= - either (\ e -> restoreBackup path >>= - either (\ e -> error ("Failed to restore backup: " ++ path ++ "~ -> " ++ path ++ ": " ++ show e)) - (\ _ -> return (Left ["Failure writing " ++ path ++ ": " ++ show e]))) + either (\ (e :: SomeException) -> + restoreBackup path >>= + either (\ e -> error ("Failed to restore backup: " ++ path ++ "~ -> " ++ path ++ ": " ++ show e)) + (\ _ -> return (Left ["Failure writing " ++ path ++ ": " ++ show e]))) (\ _ -> zipFile path)) -- | Write out three versions of a file, regular, gzipped, and bzip2ed. @@ -172,7 +173,7 @@ deleteMaybe path >>= either (\ e -> return (Left ["Failure removing " ++ path ++ ": " ++ show e])) (\ _ -> try (B.writeFile path text) >>= - either (\ e -> return (Left ["Failure writing " ++ path ++ ": " ++ show e])) + either (\ (e :: SomeException) -> return (Left ["Failure writing " ++ path ++ ": " ++ show e])) (\ _ -> zipFile path)) -- Turn a file into a backup file if it exists. @@ -203,7 +204,7 @@ maybeWriteFile path text = try (readFile path) >>= maybeWrite where - maybeWrite (Left (IOException e)) | isDoesNotExistError e = writeFile path text + maybeWrite (Left (e :: IOException)) | isDoesNotExistError e = writeFile path text maybeWrite (Left e) = error ("maybeWriteFile: " ++ show e) maybeWrite (Right old) | old == text = return () maybeWrite (Right _old) = @@ -215,7 +216,7 @@ createSymbolicLinkIfMissing :: String -> FilePath -> IO () createSymbolicLinkIfMissing text path = try (getSymbolicLinkStatus path) >>= - either (\ _ -> createSymbolicLink text path) (\ _ -> return ()) + either (\ (_ :: SomeException) -> createSymbolicLink text path) (\ _ -> return ()) prepareSymbolicLink :: FilePath -> FilePath -> IO () prepareSymbolicLink name path = @@ -245,6 +246,8 @@ -- Try something n times, returning the first Right or the last Left -- if it never succeeds. Sleep between tries. -tries :: Int -> Int -> (IO a) -> IO (Either Exception a) +--tries :: Int -> Int -> (IO a) -> IO (Either Exception a) +{- tries _ 1 f = try f >>= either (return . Left) (return . Right) -tries usec count f = try f >>= either (const (usleep usec >> tries usec (count - 1) f)) (return . Right) +tries usec count f = try f >>= either (\ (_ :: SomeException) -> usleep usec >> tries usec (count - 1) f) (return . Right) +-} diff --git a/Extra/IOThread.hs b/Extra/IOThread.hs new file mode 100644 --- /dev/null +++ b/Extra/IOThread.hs @@ -0,0 +1,41 @@ +-- |this module provides a simple mechanism for adding IO operations +-- to a queue and running them in a single thread. This is useful if +-- the IO operations have side-effects which could collide if run from +-- multiple threads. For example, creating an image thumbnail and +-- storing it on disk, running latex, etc. +module Extra.IOThread where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.Chan (Chan,newChan, readChan, writeChan) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.Exception +import Control.Monad (forever) + +newtype IOThread a b = IOThread (Chan (a, MVar (Either SomeException b))) + +-- |start the IO thread. +startIOThread :: (a -> IO b) -- ^ the IO function that does all the work + -> IO (ThreadId, IOThread a b) -- ^ a ThreadId which can be used to kill the IOThread, and a handle that can be used to issue requests to the thread. +startIOThread f = + do c <- newChan + tid <- forkIO $ ioThread f c + return (tid, IOThread c) + where + ioThread f c = + forever $ do (a, mvar) <- readChan c + b <- try $ f a + putMVar mvar b + +-- |issue a request to the IO thread and get back the result +-- if the thread function throws an exception 'ioRequest' will rethrow the exception. +ioRequest :: (IOThread a b) -- ^ handle to the IOThread + -> a -- ^ argument to the function in the IOThread + -> IO b -- ^ value returned by the function in the IOThread +ioRequest (IOThread chan) a = + do resp <- newEmptyMVar + writeChan chan (a, resp) + e <- readMVar resp + case e of + (Right r) -> return r + (Left err) -> throwIO err + diff --git a/Extra/List.hs b/Extra/List.hs --- a/Extra/List.hs +++ b/Extra/List.hs @@ -87,3 +87,8 @@ isSublistOf sub lst = maybe Nothing (\ s -> Just (length s - length sub)) (find (isSuffixOf sub) (inits lst)) + +{- +lookups :: (Eq a) => a -> [(a, b)] -> [b] +lookups a = map snd . filter ((a ==) . fst) +-} diff --git a/Extra/Lock.hs b/Extra/Lock.hs --- a/Extra/Lock.hs +++ b/Extra/Lock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Extra.Lock ( withLock , awaitLock @@ -12,14 +13,14 @@ import System.Posix.IO import System.Posix.Unistd -withLock :: (MonadIO m) => FilePath -> m a -> m (Either Exception a) +--withLock :: (MonadIO m) => FilePath -> m a -> m (Either Exception a) withLock path task = liftIO checkLock >>= liftIO . takeLock >>= doTask task >>= liftIO . dropLock where -- Return True if file is locked by a running process, false otherwise - checkLock :: IO (Either Exception ()) + --checkLock :: IO (Either Exception ()) checkLock = try (readFile path) >>= either (return . checkReadError) (processRunning . lines) - checkReadError (IOException e) | isDoesNotExistError e = (Right ()) + checkReadError (e :: IOException) | isDoesNotExistError e = (Right ()) checkReadError e = Left e processRunning (pid : _) = do exists <- doesDirectoryExist ("/proc/" ++ pid) @@ -27,11 +28,11 @@ True -> return (Left (lockedBy pid)) False -> breakLock processRunning [] = breakLock - lockedBy pid = IOException (mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path)) + lockedBy pid = mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path) breakLock = do try (removeFile path) >>= return . either checkBreakError (const (Right ())) - checkBreakError (IOException e) | isDoesNotExistError e = (Right ()) + checkBreakError (e :: IOException) | isDoesNotExistError e = (Right ()) checkBreakError e = Left e - takeLock :: Either Exception () -> IO (Either Exception ()) + --takeLock :: Either Exception () -> IO (Either Exception ()) takeLock (Right ()) = -- Try to create the lock file in exclusive mode, if this -- succeeds then we have a lock. Then write the process ID @@ -46,12 +47,12 @@ dropLock (Right a) = try (removeFile path) >>= return . checkDrop a dropLock (Left e) = return (Left e) checkDrop a (Right ()) = Right a - checkDrop a (Left (IOException e)) | isDoesNotExistError e = Right a + checkDrop a (Left (e :: IOException)) | isDoesNotExistError e = Right a checkDrop _ (Left e) = Left e -- |Like withLock, but instead of giving up immediately, try n times -- with a wait between each. -awaitLock :: (MonadIO m) => Int -> Int -> FilePath -> m a -> m (Either Exception a) +--awaitLock :: (MonadIO m) => Int -> Int -> FilePath -> m a -> m (Either Exception a) awaitLock tries usecs path task = attempt 0 where diff --git a/Extra/Misc.hs b/Extra/Misc.hs --- a/Extra/Misc.hs +++ b/Extra/Misc.hs @@ -23,8 +23,8 @@ , sameMd5sum , tarDir -- * Processes - , Extra.Misc.processOutput - , processOutput2 + -- , Extra.Misc.processOutput + -- , processOutput2 , splitOutput -- ByteString , cd @@ -33,7 +33,6 @@ ) where import Control.Exception -import Control.Monad import qualified Data.ByteString.Lazy.Char8 as B import Data.List import qualified Data.Map as Map @@ -43,8 +42,6 @@ import System.FilePath import System.Unix.Process import System.Directory -import System.Exit -import System.IO import System.Posix.Files import System.Posix.User (getEffectiveUserID) import Text.Regex @@ -130,12 +127,11 @@ do output <- lazyCommand cmd B.empty let result = case exitCodeOnly output of - [ExitFailure n] -> Left ("Error " ++ show n ++ " running '" ++ cmd ++ "'") - [ExitSuccess] -> + ExitFailure n -> Left ("Error " ++ show n ++ " running '" ++ cmd ++ "'") + ExitSuccess -> case listToMaybe . words . B.unpack . stdoutOnly $ output of Nothing -> Left $ "Error in output of '" ++ cmd ++ "'" Just checksum -> Right checksum - _ -> Left "Internal error 12" return result where cmd = "md5sum " ++ path @@ -156,32 +152,32 @@ bsum <- md5sum b return (asum == bsum) +{- -- | Backwards compatibility functions. processOutput :: String -> IO (Either Int String) processOutput command = do output <- lazyCommand command B.empty case exitCodeOnly output of - [ExitSuccess] -> return . Right . B.unpack . stdoutOnly $ output - [ExitFailure n] -> return . Left $ n + ExitSuccess -> return . Right . B.unpack . stdoutOnly $ output + ExitFailure n -> return . Left $ n _ -> error "My.processOutput: Internal error 13" processOutput2 :: String -> IO (String, ExitCode) processOutput2 command = do output <- lazyCommand command B.empty - case exitCodeOnly output of - [code] -> return ((B.unpack . stdoutOnly $ output), code) - _ -> error "My.processOutput2: Internal error 14" + return ((B.unpack . stdoutOnly $ output), exitCodeOnly output) +-} -splitOutput :: [Output] -> (B.ByteString, B.ByteString, Maybe ExitCode) -splitOutput output = (stdoutOnly output, stderrOnly output, listToMaybe (exitCodeOnly output)) +splitOutput :: [Output] -> (B.ByteString, B.ByteString, ExitCode) +splitOutput output = (stdoutOnly output, stderrOnly output, exitCodeOnly output) -- |A version of read with a more helpful error message. read' s = case reads s of [] -> error $ "read - no parse: " ++ show s - ((x, s) : _) -> x + ((x, _s) : _) -> x {- type DryRunFn = IO () -> (Bool, String) -> IO () @@ -272,8 +268,10 @@ -- | Given a tarball, return the name of the top directory. tarDir :: FilePath -> IO (Maybe String) tarDir path = - Extra.Misc.processOutput cmd >>= - return . either (const Nothing) (dir . lines) + lazyCommand cmd B.empty >>= \ output -> + case exitCodeOnly output of + ExitSuccess -> return . dir . lines . B.unpack . stdoutOnly $ output + _ -> return Nothing where cmd = "tar tfz '" ++ path ++ "'" dir [] = Nothing diff --git a/Extra/Net.hs b/Extra/Net.hs --- a/Extra/Net.hs +++ b/Extra/Net.hs @@ -8,6 +8,9 @@ -- | Parse the text returned when a directory is listed by a web -- server. This is currently only known to work with Apache. +-- NOTE: there is a second copy of this function in +-- debian:Debian.URI. Please update both locations if you make +-- changes. webServerDirectoryContents :: L.ByteString -> [String] webServerDirectoryContents text = catMaybes . map (second . matchRegex re) . lines . L.unpack $ text diff --git a/Extra/SSH.hs b/Extra/SSH.hs --- a/Extra/SSH.hs +++ b/Extra/SSH.hs @@ -4,15 +4,12 @@ , sshCopy ) where -import Control.Monad(unless) import System.Cmd import System.Directory import System.Posix.User -import System.Posix.Files import System.Environment import System.Exit import System.IO -import Network.URI import qualified Data.ByteString.Lazy.Char8 as B import System.Unix.Process @@ -40,9 +37,9 @@ do hPutStrLn stderr $ "generatePublicKey " ++ " -> " ++ keypath result <- lazyCommand cmd B.empty case exitCodeOnly result of - (ExitFailure n : _) -> + ExitFailure n -> return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ - "\n\noutput: " ++ B.unpack (outputOnly result) + "\n\noutput: " ++ B.unpack (outputOnly result) _ -> return . Right $ keypath -- |See if we already have access to the destination (user\@host). @@ -72,8 +69,8 @@ let cmd = sshOpenCmd dest port keypath result <- lazyCommand cmd B.empty case exitCodeOnly result of - (ExitFailure n : _) -> return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ - "\n\noutput: " ++ B.unpack (outputOnly result) + ExitFailure n -> return . Left $ "Failure: " ++ show cmd ++ " -> " ++ show n ++ + "\n\noutput: " ++ B.unpack (outputOnly result) _ -> return . Right $ () where sshOpenCmd dest port keypath = @@ -87,6 +84,7 @@ "chmod 600 .ssh/authorized_keys2") -- This used to be main. +{- test = getDest >>= either (return . Left) (uncurry sshExport) >>= @@ -106,6 +104,7 @@ ((n, _) : _) -> Right (user ++ host, Just n) _ -> Left $ "Invalid destination: " ++ dest checkArgs args = return . Left $ "Usage: sshexport user@host" +-} -- |Copy the ssh configuration from $HOME to the \/root directory of a -- changeroot. diff --git a/Extra/TIO.hs b/Extra/TIO.hs --- a/Extra/TIO.hs +++ b/Extra/TIO.hs @@ -1,4 +1,11 @@ {-# LANGUAGE TypeSynonymInstances #-} +-- |A value of type TIO represents the state of the terminal I/O +-- system. The 'bol' flag keeps track of whether we are at the +-- beginning of line on the console. This is computed in terms of +-- what we have sent to the console, but it should be remembered that +-- the order that stdout and stderr are sent to the console may not be +-- the same as the order in which they show up there. However, in +-- practice this seems to work as one would hope. module Extra.TIO ( module Extra.CIO -- * The TIO monad @@ -12,17 +19,8 @@ import Prelude hiding (putStr, putChar, putStrLn) import Control.Exception import Control.Monad.RWS -import Control.Monad.Reader -import Control.Monad.Trans import qualified System.IO as IO --- | This represents the state of the IO system. The 'bol' flag keeps --- track of whether we are at the beginning of line on the console. --- This is computed in terms of what we have sent to the console, but --- it should be remembered that the order that stdout and stderr are --- sent to the console may not be the same as the order in which they --- show up there. However, in practice this seems to work as one --- would hope. data TState = TState { cursor :: Position -- ^ Is the console at beginning of line? } deriving Show @@ -41,7 +39,7 @@ runTIO style action = (runRWST action) style initState >>= \ (a, _, _) -> return a -- |Catch exceptions in a TIO action. -tryTIO :: TIO a -> TIO (Either Exception a) +--tryTIO :: TIO a -> TIO (Either Exception a) tryTIO task = do state <- get liftTIO (try' state) task @@ -87,7 +85,7 @@ -- | A "virtual" newline, this puts us into the EOL state. From -- this state, a newline will be inserted before the next output, -- unless that output itself begins with a newline. - hBOL h = + hBOL _h = do state <- get put (state {cursor = if cursor state == BOL then BOL else EOL}) -- |Return the "effective verbosity", or perhaps the effective diff --git a/Extra/Terminal.hs b/Extra/Terminal.hs --- a/Extra/Terminal.hs +++ b/Extra/Terminal.hs @@ -3,7 +3,6 @@ -- Copyright Jeremy Shaw 2007 module Extra.Terminal where -import Control.Monad import System.Posix.Env import Foreign.C.Types diff --git a/Extra/URIQuery.hs b/Extra/URIQuery.hs new file mode 100644 --- /dev/null +++ b/Extra/URIQuery.hs @@ -0,0 +1,39 @@ +module Extra.URIQuery + ( modify + , del + , put + , copy + ) where + +import Data.List (partition) +import Data.Maybe (listToMaybe) +import Extra.URI + +-- |Modify an individual URI query attributes. +modify :: String -> (Maybe String -> Maybe String) -> URI -> URI +modify a vf uri = + let (vs, other) = partition ((== a) . fst) (parseURIQuery uri) in + setURIQuery (case vf (listToMaybe (map snd vs)) of + Just v' -> (a, v') : other + Nothing -> other) uri + +-- |Replace a query attribute with Nothing. +del :: String -> URI -> URI +del a uri = modify a (const Nothing) uri + +-- |Replace a query attribute with something. +put :: String -> String -> URI -> URI +put a v uri = modify a (const (Just v)) uri + +-- |Copy an attribute from one query to another +copy :: String -> URI -> URI -> URI +copy a src dst = modify a (const (lookup a (parseURIQuery src))) dst + +-- Apply f to all of the URI's pairs +{- +modifyAll :: (String -> Maybe String -> Maybe String) -> URI -> URI +modifyAll f uri = + foldr (\ (a, _) uri -> modify a (f a) uri) uri pairs + where + pairs = parseURIQuery uri +-} diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -2,4 +2,4 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/Test/QUnit.hs b/Test/QUnit.hs --- a/Test/QUnit.hs +++ b/Test/QUnit.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Test.QUnit @@ -33,9 +34,8 @@ ----------------------------------------------------------------------------- module Test.QUnit (testQuickCheck) where -import System.Random -import Test.HUnit as HU -import Test.QuickCheck as QC +import qualified Test.HUnit as HU +import qualified Test.QuickCheck as QC -- |an instance of Test.HUnit.Testable for Test.QuickCheck.Property -- @@ -45,39 +45,22 @@ -- -- Because it results in undeciable instances. For example, there is -- an instance of 'Bool' for QC.Testable and HU.Testable already. -instance HU.Testable Property where - test qc = testQuickCheck defaultConfig qc +instance HU.Testable QC.Property where + test qc = testQuickCheck QC.stdArgs qc -- |turns the quickcheck test into an hunit test -- -- Use this if you want to provide a custom 'Config' instead of -- 'defaultConfig'. testQuickCheck :: (QC.Testable a) => - Config -- ^ quickcheck config - -> a -- ^ quickcheck property - -> Test -testQuickCheck config property = - TestCase $ do rnd <- newStdGen - tests config (evaluate property) rnd 0 0 [] - --- |modified version of the tests function from Test.QuickCheck -tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () -tests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = return () - | nfail == configMaxFail config = assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests." - | otherwise = - do putStr (configEvery config ntest (arguments result)) - case ok result of - Nothing -> - tests config gen rnd1 ntest (nfail+1) stamps - Just True -> - tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - assertFailure $ ( "Falsifiable, after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 + QC.Args -- ^ quickcheck config + -> a -- ^ quickcheck property + -> HU.Test +testQuickCheck args prop = + HU.TestCase $ + do result <- QC.quickCheckWithResult args prop + case result of + (QC.Success _ _ _) -> return () + (QC.GaveUp ntest _ _) -> HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.") + (QC.Failure _ _ _ _usedSize reason _ _) -> HU.assertFailure reason + (QC.NoExpectedFailure _ _ _) -> HU.assertFailure $ "No Expected Failure"