Extra 1.33 → 1.42

raw patch · 14 files changed

+194/−112 lines, 14 filesdep +bzlibdep +zlibdep ~QuickCheckdep ~Unixutilsdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bzlib, zlib

Dependency ranges changed: QuickCheck, Unixutils, base

API changes (from Hackage documentation)

Files

• Extra.cabal +5/−4
• Extra/CIO.hs +13/−1
• Extra/Files.hs +31/−28
• Extra/IOThread.hs +41/−0
• Extra/List.hs +5/−0
• Extra/Lock.hs +9/−8
• Extra/Misc.hs +16/−18
• Extra/Net.hs +3/−0
• Extra/SSH.hs +6/−7
• Extra/TIO.hs +9/−11
• Extra/Terminal.hs +0/−1
• Extra/URIQuery.hs +39/−0
• Setup.hs +1/−1
• Test/QUnit.hs +16/−33

@@ -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 <david@seereason.com>-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:

@@ -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,

@@ -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)+-}

@@ -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+            

@@ -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)+-}

@@ -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 

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -3,7 +3,6 @@ -- Copyright Jeremy Shaw 2007 module Extra.Terminal where -import Control.Monad import System.Posix.Env import Foreign.C.Types 

@@ -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+-}

@@ -2,4 +2,4 @@  import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks simpleUserHooks

@@ -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"