diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,11 @@ Changelog for Extra +0.5 + Use the sortOn from GHC 7.9 and above + Remove getProcessorCount + Remove getDirectoryContentsRecursive in favour of listFilesRecursive + Change the signature for newTempFile/newTempDir + Add a once function 0.4 Remove all but the extractors on triples Remove groupSortOn diff --git a/Generate.hs b/Generate.hs --- a/Generate.hs +++ b/Generate.hs @@ -42,7 +42,12 @@ ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))" ,"tests :: IO ()" ,"tests = do"] ++ - [" testGen " ++ show t ++ " $ " ++ tweakTest t | (_,_,ts) <- ifaces, t <- ts] + [" " ++ if "let " `isPrefixOf` t then t else "testGen " ++ show t ++ " $ " ++ tweakTest t | (_,_,ts) <- ifaces, t <- rejoin ts] + +rejoin :: [String] -> [String] +rejoin (x1:x2:xs) | " " `isPrefixOf` x2 = rejoin $ (x1 ++ x2) : xs +rejoin (x:xs) = x : rejoin xs +rejoin [] = [] writeFileBinaryChanged :: FilePath -> String -> IO () writeFileBinaryChanged file x = do diff --git a/extra.cabal b/extra.cabal --- a/extra.cabal +++ b/extra.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: extra -version: 0.4 +version: 0.5 license: BSD3 license-file: LICENSE category: Development @@ -60,6 +60,8 @@ default-language: Haskell2010 build-depends: base == 4.*, + directory, + filepath, extra, time, QuickCheck diff --git a/src/Control/Concurrent/Extra.hs b/src/Control/Concurrent/Extra.hs --- a/src/Control/Concurrent/Extra.hs +++ b/src/Control/Concurrent/Extra.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, TupleSections #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Extra functions for "Control.Concurrent". These fall into a few categories: +-- | Extra functions for "Control.Concurrent". -- --- * Some functions manipulate the number of capabilities. +-- This module includes three new types of 'MVar', namely 'Lock' (no associated value), +-- 'Var' (never empty) and 'Barrier' (filled at most once). See +-- +-- for examples and justification. -- --- * The 'forkFinally' function - if you need greater control of exceptions and threads +-- If you need greater control of exceptions and threads -- see the package. --- --- * Three new types of 'MVar', namely 'Lock' (no associated value), 'Var' (never empty) --- and 'Barrier' (filled at most once). See --- --- for more examples. +-- If you need elaborate relationships between threads +-- see the package. module Control.Concurrent.Extra( module Control.Concurrent, - withNumCapabilities, setNumCapabilities, - forkFinally, + getNumCapabilities, setNumCapabilities, withNumCapabilities, + forkFinally, once, -- * Lock Lock, newLock, withLock, withLockTry, -- * Var @@ -25,7 +25,7 @@ ) where import Control.Concurrent -import Control.Exception +import Control.Exception.Extra import Control.Monad.Extra @@ -38,6 +38,12 @@ bracket_ (setNumCapabilities new) (setNumCapabilities old) act +#if __GLASGOW_HASKELL__ < 702 +-- | A version of 'getNumCapabilities' that works on all versions of GHC, but returns 1 before GHC 7.2. +getNumCapabilities :: IO Int +getNumCapabilities = return 1 +#endif + #if __GLASGOW_HASKELL__ < 706 -- | A version of 'setNumCapabilities' that works on all versions of GHC, but has no effect before GHC 7.6. setNumCapabilities :: Int -> IO () @@ -63,6 +69,26 @@ mask $ \restore -> forkIO $ try (restore action) >>= and_then #endif + + +data Once a = OncePending | OnceRunning (Barrier a) | OnceDone a + + +-- | Given an action, produce a wrapped action that runs at most once. +-- If the function raises an exception, the same exception will be reraised each time. +once :: IO a -> IO (IO a) +once act = do + var <- newVar OncePending + let run = either throw return + return $ join $ modifyVar var $ \v -> case v of + OnceDone x -> return (v, run x) + OnceRunning x -> return (v, run =<< waitBarrier x) + OncePending -> do + b <- newBarrier + return $ (OnceRunning b,) $ do + res <- try_ act + modifyVar_ var $ \_ -> return $ OnceDone res + run res --------------------------------------------------------------------- diff --git a/src/Control/Exception/Extra.hs b/src/Control/Exception/Extra.hs --- a/src/Control/Exception/Extra.hs +++ b/src/Control/Exception/Extra.hs @@ -20,9 +20,10 @@ -- | Fully evaluate an input String. If the String contains embedded exceptions it will produce @\@. -- +-- > stringException "test" == return "test" -- > stringException ("test" ++ undefined) == return "test" -- > stringException ("test" ++ undefined ++ "hello") == return "test" --- > stringException "test" == return "test" +-- > stringException ['t','e','s','t',undefined] == return "test" stringException :: String -> IO String stringException x = do r <- try_ $ evaluate $ list [] (\x xs -> x `seq` x:xs) x @@ -48,7 +49,8 @@ ignore = void . try_ --- | Retry an operation at most N times (N must be positive). +-- | Retry an operation at most /n/ times (/n/ must be positive). +-- If the operation fails the /n/th time it will throw that final exception. -- -- > retry 1 (print "x") == print "x" -- > retry 3 (fail "die") == fail "die" diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs --- a/src/Control/Monad/Extra.hs +++ b/src/Control/Monad/Extra.hs @@ -1,17 +1,18 @@ --- | Extra functions for "Control.Exception". +-- | Extra functions for "Control.Monad". -- These functions provide looping, list operations and booleans. -- If you need a wider selection of monad loops and list generalisations, --- see +-- see . module Control.Monad.Extra( module Control.Monad, whenJust, unit, - partitionM, concatMapM, mapMaybeM, + -- * Loops loopM, whileM, - whenM, unlessM, - ifM, notM, (||^), (&&^), orM, andM, anyM, allM, - findM, firstJustM + -- * Lists + partitionM, concatMapM, mapMaybeM, findM, firstJustM, + -- * Booleans + whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, ) where import Control.Monad @@ -27,7 +28,7 @@ whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust mg f = maybe (pure ()) f mg --- | The identity function which requires the inner argument to be '()'. Useful for functions +-- | The identity function which requires the inner argument to be @()@. Useful for functions -- with overloaded return times. -- -- > \(x :: Maybe ()) -> unit x == x diff --git a/src/Data/IORef/Extra.hs b/src/Data/IORef/Extra.hs --- a/src/Data/IORef/Extra.hs +++ b/src/Data/IORef/Extra.hs @@ -10,13 +10,13 @@ import Control.Exception --- | Evaluates the value before calling 'writeIORef' +-- | Evaluates the value before calling 'writeIORef'. writeIORef' :: IORef a -> a -> IO () writeIORef' ref x = do evaluate x writeIORef ref x --- | Evaluates the value before calling 'atomicWriteIORef' +-- | Evaluates the value before calling 'atomicWriteIORef'. atomicWriteIORef' :: IORef a -> a -> IO () atomicWriteIORef' ref x = do evaluate x diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -3,18 +3,25 @@ -- | This module extends "Data.List" with extra functions of a similar nature. -- The package also exports the existing "Data.List" functions. --- Some of the names and semantics were inspired by the @text@ package. +-- Some of the names and semantics were inspired by the +-- package. module Data.List.Extra( module Data.List, - lower, upper, trim, trimStart, trimEnd, word1, drop1, - list, uncons, unsnoc, cons, snoc, + -- * String operations + lower, upper, trim, trimStart, trimEnd, word1, + -- * Splitting + dropEnd, takeEnd, breakEnd, spanEnd, + dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, + wordsBy, linesBy, + breakOn, breakOnEnd, splitOn, split, chunksOf, + -- * Basics + list, uncons, unsnoc, cons, snoc, drop1, + -- * List operations groupSort, nubOn, groupOn, sortOn, - repeatedly, for, disjoint, allSame, anySame, - dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, + repeatedly, for, firstJust, concatUnzip, concatUnzip3, - merge, mergeBy, replace, wordsBy, linesBy, firstJust, - breakOn, breakOnEnd, splitOn, split, chunksOf + replace, merge, mergeBy, ) where import Data.List @@ -197,23 +204,43 @@ upper = map toUpper +-- | Split the first word off a string. Useful for when starting to parse the beginning +-- of a string, but you want to accurately perserve whitespace in the rest of the string. +-- +-- > word1 "" == ("", "") +-- > word1 "keyword rest of string" == ("keyword","rest of string") +-- > word1 " keyword\n rest of string" == ("keyword","rest of string") +-- > \s -> fst (word1 s) == concat (take 1 $ words s) +-- > \s -> words (snd $ word1 s) == drop 1 (words s) word1 :: String -> (String, String) word1 x = second (dropWhile isSpace) $ break isSpace $ dropWhile isSpace x --- | A version of 'sort' where the comparison is done on some extracted value. +#if __GLASGOW_HASKELL__ < 709 +-- | Sort a list by comparing the results of a key function applied to each +-- element. @sortOn f@ is equivalent to @sortBy (comparing f)@, but has the +-- performance advantage of only evaluating @f@ once for each element in the +-- input list. This is called the decorate-sort-undecorate paradigm, or +-- Schwartzian transform. -- -- > sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")] sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = sortBy (compare `on` f) +sortOn f = map snd . sortBy (compare `on` fst) . map (\x -> let y = f x in y `seq` (y, x)) +#endif -- | A version of 'group' where the equality is done on some extracted value. groupOn :: Eq b => (a -> b) -> [a] -> [[a]] -groupOn f = groupBy ((==) `on` f) +groupOn f = groupBy ((==) `on2` f) + -- redefine on so we avoid duplicate computation for most values. + where (.*.) `on2` f = \x -> let fx = f x in \y -> fx .*. f y + -- | A version of 'nub' where the equality is done on some extracted value. +-- @nubOn f@ is equivalent to @nubBy ((==) `on` f)@, but has the +-- performance advantage of only evaluating @f@ once for each element in the +-- input list. nubOn :: Eq b => (a -> b) -> [a] -> [a] -nubOn f = nubBy ((==) `on` f) +nubOn f = map snd . nubBy ((==) `on` fst) . map (\x -> let y = f x in y `seq` (y, x)) -- | A combination of 'group' and 'sort'. -- diff --git a/src/Data/Tuple/Extra.hs b/src/Data/Tuple/Extra.hs --- a/src/Data/Tuple/Extra.hs +++ b/src/Data/Tuple/Extra.hs @@ -1,7 +1,7 @@ --- | Extra functions for working with tuples. +-- | Extra functions for working with pairs and triples. -- Some of these functions are available in the "Control.Arrow" module, --- but here are available specialised to pairs. +-- but here are available specialised to pairs. Some operations work on triples. module Data.Tuple.Extra( module Data.Tuple, -- * Specialised 'Arrow' functions @@ -49,7 +49,7 @@ dupe :: a -> (a,a) dupe x = (x,x) --- | Apply a single function to both componenets of a pair. +-- | Apply a single function to both components of a pair. -- -- > both succ (1,2) == (2,3) both :: (a -> b) -> (a, a) -> (b, b) diff --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -5,13 +5,13 @@ module Extra( -- * Control.Concurrent.Extra -- | Extra functions available in @"Control.Concurrent.Extra"@. - withNumCapabilities, setNumCapabilities, forkFinally, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, + getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, once, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, -- * Control.Exception.Extra -- | Extra functions available in @"Control.Exception.Extra"@. retry, showException, stringException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, -- * Control.Monad.Extra -- | Extra functions available in @"Control.Monad.Extra"@. - whenJust, unit, partitionM, concatMapM, mapMaybeM, loopM, whileM, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, findM, firstJustM, + whenJust, unit, loopM, whileM, partitionM, concatMapM, mapMaybeM, findM, firstJustM, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, -- * Data.Either.Extra -- | Extra functions available in @"Data.Either.Extra"@. isLeft, isRight, fromLeft, fromRight, fromEither, @@ -20,7 +20,7 @@ modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef', -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. - lower, upper, trim, trimStart, trimEnd, word1, drop1, list, uncons, unsnoc, cons, snoc, groupSort, nubOn, groupOn, sortOn, repeatedly, for, disjoint, allSame, anySame, dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, concatUnzip, concatUnzip3, merge, mergeBy, replace, wordsBy, linesBy, firstJust, breakOn, breakOnEnd, splitOn, split, chunksOf, + lower, upper, trim, trimStart, trimEnd, word1, dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, groupSort, nubOn, groupOn, sortOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, replace, merge, mergeBy, -- * Data.Tuple.Extra -- | Extra functions available in @"Data.Tuple.Extra"@. first, second, (***), (&&&), dupe, both, fst3, snd3, thd3, @@ -29,16 +29,16 @@ showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat, -- * System.Directory.Extra -- | Extra functions available in @"System.Directory.Extra"@. - withCurrentDirectory, getDirectoryContentsRecursive, createDirectoryPrivate, + withCurrentDirectory, createDirectoryPrivate, listContents, listFiles, listFilesInside, listFilesRecursive, -- * System.Environment.Extra -- | Extra functions available in @"System.Environment.Extra"@. getExecutablePath, lookupEnv, -- * System.Info.Extra -- | Extra functions available in @"System.Info.Extra"@. - isWindows, getProcessorCount, + isWindows, -- * System.IO.Extra -- | Extra functions available in @"System.IO.Extra"@. - readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, captureOutput, withBuffering, + captureOutput, withBuffering, readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, -- * System.Process.Extra -- | Extra functions available in @"System.Process.Extra"@. system_, systemOutput, systemOutput_, diff --git a/src/Numeric/Extra.hs b/src/Numeric/Extra.hs --- a/src/Numeric/Extra.hs +++ b/src/Numeric/Extra.hs @@ -1,4 +1,5 @@ +-- | Extra numeric functions - formatting and specialised conversions. module Numeric.Extra( module Numeric, showDP, diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs --- a/src/System/Directory/Extra.hs +++ b/src/System/Directory/Extra.hs @@ -1,8 +1,11 @@ {-# LANGUAGE CPP #-} +-- | Extra directory functions. Most of these functions provide cleaned up and generalised versions +-- of 'getDirectoryContents', see 'listContents' for the differences. module System.Directory.Extra( module System.Directory, - withCurrentDirectory, getDirectoryContentsRecursive, createDirectoryPrivate + withCurrentDirectory, createDirectoryPrivate, + listContents, listFiles, listFilesInside, listFilesRecursive ) where import System.Directory @@ -16,21 +19,57 @@ #endif --- | Remember that the current directory is a global variable, so calling this function --- multithreaded is almost certain to go wrong. Avoid changing the dir if you can. +-- | Set the current directory, perform an operation, then change back. +-- Remember that the current directory is a global variable, so calling this function +-- multithreaded is almost certain to go wrong. Avoid changing the current directory if you can. +-- +-- > withTempDir $ \dir -> do writeFile (dir "foo.txt") ""; withCurrentDirectory dir $ doesFileExist "foo.txt" withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory dir act = bracket getCurrentDirectory setCurrentDirectory $ const $ do setCurrentDirectory dir; act --- | Find all the files within a directory, including recursively. --- Looks through all folders, including those beginning with @.@. -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive dir = do + +-- | List the files and directories directly within a directory. +-- Each result will be prefixed by the query directory, and the special directories @.@ and @..@ will be ignored. +-- Intended as a cleaned up version of 'getDirectoryContents'. +-- +-- > withTempDir $ \dir -> do writeFile (dir "test.txt") ""; (== [dir "test.txt"]) <$> listContents dir +-- > let touch = mapM_ $ \x -> createDirectoryIfMissing True (takeDirectory x) >> writeFile x "" +-- > let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir ) as; res <- op dir; return $ map (drop (length dir + 1)) res == bs +-- > listTest listContents ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","foo","zoo"] +listContents :: FilePath -> IO [FilePath] +listContents dir = do xs <- getDirectoryContents dir - (dirs,files) <- partitionM doesDirectoryExist [dir x | x <- xs, not $ all (== '.') x] - rest <- concatMapM getDirectoryContentsRecursive $ sort dirs - return $ sort files ++ rest + return $ sort [dir x | x <- xs, not $ all (== '.') x] + +-- | Like 'listContents', but only returns the files in a directory, not other directories. +-- Each file will be prefixed by the query directory. +-- +-- > listTest listFiles ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","zoo"] +listFiles :: FilePath -> IO [FilePath] +listFiles dir = filterM doesFileExist =<< listContents dir + + +-- | Like 'listFiles', but goes recursively through all subdirectories. +-- +-- > listTest listFilesRecursive ["bar.txt","zoo","foo" "baz.txt"] ["bar.txt","zoo","foo" "baz.txt"] +listFilesRecursive :: FilePath -> IO [FilePath] +listFilesRecursive = listFilesInside (const $ return True) + + +-- | Like 'listFilesRecursive', but with a predicate to decide where to recurse into. +-- Typically directories starting with @.@ would be ignored. The initial argument directory +-- will have the test applied to it. +-- +-- > listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName) +-- > ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] +-- > listTest (listFilesInside $ const $ return False) ["bar.txt"] [] +listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] +listFilesInside test dir = ifM (notM $ test dir) (return []) $ do + (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir + rest <- concatMapM (listFilesInside test) dirs + return $ files ++ rest -- | Create a directory with permissions so that only the current user can view it. diff --git a/src/System/Environment/Extra.hs b/src/System/Environment/Extra.hs --- a/src/System/Environment/Extra.hs +++ b/src/System/Environment/Extra.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +-- | Extra functions for "System.Environment". All these functions are available in later GHC versions, +-- but this code works all the way back to GHC 7.2. module System.Environment.Extra( module System.Environment, getExecutablePath, lookupEnv diff --git a/src/System/IO/Extra.hs b/src/System/IO/Extra.hs --- a/src/System/IO/Extra.hs +++ b/src/System/IO/Extra.hs @@ -1,17 +1,25 @@ {-# LANGUAGE ScopedTypeVariables #-} --- | More advanced temporary file manipulation functions can be found in the @exceptions@ package. +-- | More IO functions. The functions include ones for reading files with specific encodings, +-- strictly reading files, and writing files with encodings. There are also some simple +-- temporary file functions, more advanced alternatives can be found in +-- the package. module System.IO.Extra( module System.IO, + captureOutput, + withBuffering, + -- * Read encoding readFileEncoding, readFileUTF8, readFileBinary, + -- * Strict reading readFile', readFileEncoding', readFileUTF8', readFileBinary', + -- * Write with encoding writeFileEncoding, writeFileUTF8, writeFileBinary, + -- * Temporary files withTempFile, withTempDir, newTempFile, newTempDir, - captureOutput, - withBuffering, ) where import System.IO +import Control.Concurrent.Extra import Control.Exception.Extra as E import GHC.IO.Handle(hDuplicate,hDuplicateTo) import System.Directory.Extra @@ -23,15 +31,18 @@ -- File reading +-- | Like 'readFile', but setting an encoding. readFileEncoding :: TextEncoding -> FilePath -> IO String readFileEncoding enc file = do h <- openFile file ReadMode hSetEncoding h enc hGetContents h +-- | Like 'readFile', but with the encoding 'utf8'. readFileUTF8 :: FilePath -> IO String readFileUTF8 = readFileEncoding utf8 +-- | Like 'readFile', but for binary files. readFileBinary :: FilePath -> IO String readFileBinary file = do h <- openBinaryFile file ReadMode @@ -39,12 +50,16 @@ -- Strict file reading +-- | A strict version of 'readFile'. When the string is produced, the entire +-- file will have been read into memory and the file handle will have been closed. +-- Closing the file handle does not rely on the garbage collector. readFile' :: FilePath -> IO String readFile' file = withFile file ReadMode $ \h -> do s <- hGetContents h evaluate $ length s return s +-- | A strict version of 'readFileEncoding', see 'readFile'' for details. readFileEncoding' :: TextEncoding -> FilePath -> IO String readFileEncoding' e file = withFile file ReadMode $ \h -> do hSetEncoding h e @@ -52,9 +67,11 @@ evaluate $ length s return s +-- | A strict version of 'readFileUTF8', see 'readFile'' for details. readFileUTF8' :: FilePath -> IO String readFileUTF8' = readFileEncoding' utf8 +-- | A strict version of 'readFileBinary', see 'readFile'' for details. readFileBinary' :: FilePath -> IO String readFileBinary' file = withBinaryFile file ReadMode $ \h -> do s <- hGetContents h @@ -63,14 +80,17 @@ -- File writing +-- | Write a file with a particular encoding. writeFileEncoding :: TextEncoding -> FilePath -> String -> IO () writeFileEncoding enc file x = withFile x WriteMode $ \h -> do hSetEncoding h enc hPutStr h x +-- | Write a file with the 'utf8' encoding. writeFileUTF8 :: FilePath -> String -> IO () writeFileUTF8 = writeFileEncoding utf8 +-- | Write a binary file. writeFileBinary :: FilePath -> String -> IO () writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x @@ -97,6 +117,8 @@ hSetBuffering out buf +-- | Execute an action with a custom 'BufferMode', a warpper around +-- 'hSetBuffering'. withBuffering :: Handle -> BufferMode -> IO a -> IO a withBuffering h m act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do hSetBuffering h m @@ -104,8 +126,14 @@ -- Temporary file -newTempFile :: (IO FilePath, FilePath -> IO ()) -newTempFile = (create, ignore . removeFile) +-- | Provide a function to create a temporary file, and a way to delete a +-- temporary file. Most users should use 'withTempFile' which +-- combines these operations. +newTempFile :: IO (FilePath, IO ()) +newTempFile = do + file <- create + del <- once $ ignore $ removeFile file + return (file, del) where create = do tmpdir <- getTemporaryDirectory @@ -114,11 +142,28 @@ return file +-- | Create a temporary file in the temporary directory. The file will be deleted +-- after the action completes (provided the file is not still open). +-- The 'FilePath' will not have any file extension, will exist, and will be zero bytes long. +-- If you require a file with a specific name, use 'withTempDir'. +-- +-- > withTempFile doesFileExist == return True +-- > (doesFileExist =<< withTempFile return) == return False +-- > withTempFile readFile' == return "" withTempFile :: (FilePath -> IO a) -> IO a -withTempFile = uncurry bracket newTempFile +withTempFile act = do + (file, del) <- newTempFile + act file `finally` del -newTempDir :: (IO FilePath, FilePath -> IO ()) -newTempDir = (create, ignore . removeDirectoryRecursive) + +-- | Provide a function to create a temporary directory, and a way to delete a +-- temporary directory. Most users should use 'withTempDir' which +-- combines these operations. +newTempDir :: IO (FilePath, IO ()) +newTempDir = do + dir <- create + del <- once $ ignore $ removeDirectoryRecursive dir + return (dir, del) where create = do tmpdir <- getTemporaryDirectory @@ -133,5 +178,13 @@ \e -> find tmpdir (x+1) +-- | Create a temporary directory inside the system temporary directory. +-- The directory will be deleted after the action completes. +-- +-- > withTempDir doesDirectoryExist == return True +-- > (doesDirectoryExist =<< withTempDir return) == return False +-- > withTempDir listFiles == return [] withTempDir :: (FilePath -> IO a) -> IO a -withTempDir = uncurry bracket newTempDir +withTempDir act = do + (dir,del) <- newTempDir + act dir `finally` del diff --git a/src/System/Info/Extra.hs b/src/System/Info/Extra.hs --- a/src/System/Info/Extra.hs +++ b/src/System/Info/Extra.hs @@ -1,47 +1,25 @@ {-# LANGUAGE CPP #-} +-- | Extra functions for the current system info. module System.Info.Extra( module System.Info, - isWindows, getProcessorCount + isWindows ) where import System.Info -import System.IO.Unsafe -import Control.Exception.Extra -import System.Environment.Extra -import Foreign.C.Types -import Control.Concurrent -import Data.List --------------------------------------------------------------------- -- System.Info +-- | Return 'True' on Windows and 'False' otherwise. A runtime version of @#ifdef minw32_HOST_OS@. +-- Equivalent to @os == \"mingw32\"@, but: more efficient; doesn't require typing an easily +-- mistypeable string; actually asks about your OS not a library; doesn't bake in +-- 32bit assumptions that are already false. \<\/rant\> +-- +-- > isWindows == (os == "mingw32") isWindows :: Bool #if defined(mingw32_HOST_OS) isWindows = True #else isWindows = False #endif - - --- Use the underlying GHC function -foreign import ccall getNumberOfProcessors :: IO CInt - - -{-# NOINLINE getProcessorCount #-} -getProcessorCount :: IO Int --- unsafePefromIO so we cache the result and only compute it once -getProcessorCount = let res = unsafePerformIO act in return res - where - act = - if rtsSupportsBoundThreads then - fmap fromIntegral getNumberOfProcessors - else - handle_ (const $ return 1) $ do - env <- lookupEnv "NUMBER_OF_PROCESSORS" - case env of - Just s | [(i,"")] <- reads s -> return i - _ -> do - src <- readFile "/proc/cpuinfo" - return $ length [() | x <- lines src, "processor" `isPrefixOf` x] - diff --git a/src/System/Process/Extra.hs b/src/System/Process/Extra.hs --- a/src/System/Process/Extra.hs +++ b/src/System/Process/Extra.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TupleSections #-} +-- | Extra functions for creating processes. Specifically variants that automatically check +-- the 'ExitCode' and capture the 'stdout'\/'stderr' handles. module System.Process.Extra( module System.Process, system_, systemOutput, systemOutput_ @@ -12,7 +14,7 @@ -- | A version of 'system' that also captures the output, both 'stdout' and 'stderr'. --- Returns a pair of the exit code and the output. +-- Returns a pair of the 'ExitCode' and the output. systemOutput :: String -> IO (ExitCode, String) systemOutput x = withTempFile $ \file -> do exit <- withFile file WriteMode $ \h -> do diff --git a/src/System/Time/Extra.hs b/src/System/Time/Extra.hs --- a/src/System/Time/Extra.hs +++ b/src/System/Time/Extra.hs @@ -1,4 +1,9 @@ +-- | Extra functions for working with times. Unlike the other modules in this package, there is no +-- corresponding @System.Time@ module. This module enhances the functionality +-- from "Data.Time.Clock", but in quite different ways. +-- +-- Throughout, time is measured in 'Seconds', which is a type alias for 'Double'. module System.Time.Extra( Seconds, sleep, diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -4,9 +4,10 @@ default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () tests = do + testGen "stringException \"test\" == return \"test\"" $ stringException "test" == return "test" testGen "stringException (\"test\" ++ undefined) == return \"test\"" $ stringException ("test" ++ undefined) == return "test" testGen "stringException (\"test\" ++ undefined ++ \"hello\") == return \"test\"" $ stringException ("test" ++ undefined ++ "hello") == return "test" - testGen "stringException \"test\" == return \"test\"" $ stringException "test" == return "test" + testGen "stringException ['t','e','s','t',undefined] == return \"test\"" $ stringException ['t','e','s','t',undefined] == return "test" testGen "ignore (print 1) == print 1" $ ignore (print 1) == print 1 testGen "ignore (fail \"die\") == return ()" $ ignore (fail "die") == return () testGen "retry 1 (print \"x\") == print \"x\"" $ retry 1 (print "x") == print "x" @@ -94,6 +95,11 @@ testGen "lower \"\" == \"\"" $ lower "" == "" testGen "upper \"This is A TEST\" == \"THIS IS A TEST\"" $ upper "This is A TEST" == "THIS IS A TEST" testGen "upper \"\" == \"\"" $ upper "" == "" + testGen "word1 \"\" == (\"\", \"\")" $ word1 "" == ("", "") + testGen "word1 \"keyword rest of string\" == (\"keyword\",\"rest of string\")" $ word1 "keyword rest of string" == ("keyword","rest of string") + testGen "word1 \" keyword\\n rest of string\" == (\"keyword\",\"rest of string\")" $ word1 " keyword\n rest of string" == ("keyword","rest of string") + testGen "\\s -> fst (word1 s) == concat (take 1 $ words s)" $ \s -> fst (word1 s) == concat (take 1 $ words s) + testGen "\\s -> words (snd $ word1 s) == drop 1 (words s)" $ \s -> words (snd $ word1 s) == drop 1 (words s) testGen "sortOn fst [(3,\"z\"),(1,\"\"),(3,\"a\")] == [(1,\"\"),(3,\"z\"),(3,\"a\")]" $ sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")] testGen "groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,\"t\"),(2,\"es\"),(3,\"t\")]" $ groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,"t"),(2,"es"),(3,"t")] testGen "\\xs -> map fst (groupSort xs) == sort (nub (map fst xs))" $ \xs -> map fst (groupSort xs) == sort (nub (map fst xs)) @@ -156,7 +162,23 @@ testGen "showDP 4 pi == \"3.1416\"" $ showDP 4 pi == "3.1416" testGen "showDP 0 pi == \"3\"" $ showDP 0 pi == "3" testGen "showDP 2 3 == \"3.00\"" $ showDP 2 3 == "3.00" + testGen "withTempDir $ \\dir -> do writeFile (dir \"foo.txt\") \"\"; withCurrentDirectory dir $ doesFileExist \"foo.txt\"" $ withTempDir $ \dir -> do writeFile (dir "foo.txt") ""; withCurrentDirectory dir $ doesFileExist "foo.txt" + testGen "withTempDir $ \\dir -> do writeFile (dir \"test.txt\") \"\"; (== [dir \"test.txt\"]) <$> listContents dir" $ withTempDir $ \dir -> do writeFile (dir "test.txt") ""; (== [dir "test.txt"]) <$> listContents dir + let touch = mapM_ $ \x -> createDirectoryIfMissing True (takeDirectory x) >> writeFile x "" + let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir ) as; res <- op dir; return $ map (drop (length dir + 1)) res == bs + testGen "listTest listContents [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"bar.txt\",\"foo\",\"zoo\"]" $ listTest listContents ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","foo","zoo"] + testGen "listTest listFiles [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"bar.txt\",\"zoo\"]" $ listTest listFiles ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","zoo"] + testGen "listTest listFilesRecursive [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"] [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"]" $ listTest listFilesRecursive ["bar.txt","zoo","foo" "baz.txt"] ["bar.txt","zoo","foo" "baz.txt"] + testGen "listTest (listFilesInside $ return . not . isPrefixOf \".\" . takeFileName) [\"bar.txt\",\"foo\" \"baz.txt\",\".foo\" \"baz2.txt\", \"zoo\"] [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"]" $ listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName) ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] + testGen "listTest (listFilesInside $ const $ return False) [\"bar.txt\"] []" $ listTest (listFilesInside $ const $ return False) ["bar.txt"] [] + testGen "isWindows == (os == \"mingw32\")" $ isWindows == (os == "mingw32") testGen "captureOutput (print 1) == return (\"1\\n\",())" $ captureOutput (print 1) == return ("1\n",()) + testGen "withTempFile doesFileExist == return True" $ withTempFile doesFileExist == return True + testGen "(doesFileExist =<< withTempFile return) == return False" $ (doesFileExist =<< withTempFile return) == return False + testGen "withTempFile readFile' == return \"\"" $ withTempFile readFile' == return "" + testGen "withTempDir doesDirectoryExist == return True" $ withTempDir doesDirectoryExist == return True + testGen "(doesDirectoryExist =<< withTempDir return) == return False" $ (doesDirectoryExist =<< withTempDir return) == return False + testGen "withTempDir listFiles == return []" $ withTempDir listFiles == return [] testGen "fmap (round . fst) (duration $ sleep 1) == return 1" $ fmap (round . fst) (duration $ sleep 1) == return 1 testGen "\\a b -> a > b ==> subtractTime a b > 0" $ \a b -> a > b ==> subtractTime a b > 0 testGen "showDuration 3.435 == \"3.44s\"" $ showDuration 3.435 == "3.44s" diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -1,5 +1,5 @@ -module TestUtil(runTests, testGen, erroneous, module X) where +module TestUtil(runTests, testGen, erroneous, (====), module X) where import Test.QuickCheck import Test.QuickCheck.Test @@ -13,11 +13,15 @@ import Text.Show.Functions() import Extra as X +import Control.Applicative as X import Control.Monad as X import Data.List as X import Data.Char as X import Data.Tuple as X -import Test.QuickCheck as X +import System.Directory as X +import System.FilePath as X +import System.Info as X +import Test.QuickCheck as X((==>)) {-# NOINLINE testCount #-} @@ -35,6 +39,8 @@ erroneous :: a -> Bool erroneous x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate x +(====) :: (Show a, Eq a) => a -> a -> Bool +a ==== b = if a == b then True else error $ "Not equal!\n" ++ show a ++ "\n" ++ show b runTests :: IO () -> IO () runTests t = do