packages feed

extra 1.6.20 → 1.6.21

raw patch · 16 files changed

+159/−120 lines, 16 filesdep +quickcheck-instancesPVP ok

version bump matches the API change (PVP)

Dependencies added: quickcheck-instances

API changes (from Hackage documentation)

+ Data.List.NonEmpty.Extra: nubOrd :: Ord a => NonEmpty a -> NonEmpty a
+ Data.List.NonEmpty.Extra: nubOrdBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
+ Data.List.NonEmpty.Extra: nubOrdOn :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a

Files

CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for Extra +1.6.21, released 2020-03-02+    #54, deprecate nubOn since its O(n^2). Use nubOrdOn+    #53, add some nub functions to NonEmpty 1.6.20, released 2020-02-16     Add firstM, secondM 1.6.19, released 2020-02-11
Generate.hs view
@@ -25,7 +25,7 @@                     words $ replace "," " " $ drop1 $ dropWhile (/= '(') $                     unlines $ filter (\x -> not $ any (`isPrefixOf` trim x) ["--","#"]) $ lines src         let tests = mapMaybe (stripPrefix "-- > ") $ lines src-        return (mod, funcs, tests)+        pure (mod, funcs, tests)     writeFileBinaryChanged "src/Extra.hs" $ unlines $         ["-- GENERATED CODE - DO NOT MODIFY"         ,"-- See Generate.hs for details of how to generate"@@ -49,6 +49,9 @@         ,"{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-}"         ,"module TestGen(tests) where"         ,"import TestUtil"+        ,"import qualified Data.List"+        ,"import qualified Data.List.NonEmpty.Extra"+        ,"import Test.QuickCheck.Instances.Semigroup ()"         ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))"         ,"tests :: IO ()"         ,"tests = do"] ++@@ -62,12 +65,14 @@ writeFileBinaryChanged :: FilePath -> String -> IO () writeFileBinaryChanged file x = do     evaluate $ length x -- ensure we don't write out files with _|_ in them-    old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (return Nothing)+    old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (pure Nothing)     when (Just x /= old) $         writeFileBinary file x  hidden :: String -> [String]-hidden "Data.List.NonEmpty.Extra" = ["cons", "snoc", "sortOn", "union", "unionBy"]+hidden "Data.List.NonEmpty.Extra" = [ "cons", "snoc", "sortOn", "union", "unionBy"+                                    , "nubOrd", "nubOrdBy", "nubOrdOn"+                                    ] hidden _ = []  notHidden :: String -> String -> Bool
extra.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               extra-version:            1.6.20+version:            1.6.21 license:            BSD3 license-file:       LICENSE category:           Development@@ -73,7 +73,8 @@         directory,         filepath,         extra,-        QuickCheck >= 2.10+        QuickCheck >= 2.10,+        quickcheck-instances >= 0.3.17     if !os(windows)         build-depends: unix     hs-source-dirs: test
src/Control/Concurrent/Extra.hs view
@@ -46,23 +46,23 @@ --   If the function raises an exception, the same exception will be reraised each time. -- -- > let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2--- > \(x :: IO Int) -> void (once x) == return ()+-- > \(x :: IO Int) -> void (once x) == pure () -- > \(x :: IO Int) -> join (once x) == x -- > \(x :: IO Int) -> (do y <- once x; y; y) == x -- > \(x :: IO Int) -> (do y <- once x; y ||| y) == x once :: IO a -> IO (IO a) once act = do     var <- newVar OncePending-    let run = either throwIO return-    return $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of-        OnceDone x -> return (v, unmask $ run x)-        OnceRunning x -> return (v, unmask $ run =<< waitBarrier x)+    let run = either throwIO pure+    pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of+        OnceDone x -> pure (v, unmask $ run x)+        OnceRunning x -> pure (v, unmask $ run =<< waitBarrier x)         OncePending -> do             b <- newBarrier-            return $ (OnceRunning b,) $ do+            pure $ (OnceRunning b,) $ do                 res <- try_ $ unmask act                 signalBarrier b res-                modifyVar_ var $ \_ -> return $ OnceDone res+                modifyVar_ var $ \_ -> pure $ OnceDone res                 run res  data Once a = OncePending | OnceRunning (Barrier a) | OnceDone a@@ -76,7 +76,7 @@ onceFork act = do     bar <- newBarrier     forkFinally act $ signalBarrier bar-    return $ eitherM throwIO return $ waitBarrier bar+    pure $ eitherM throwIO pure $ waitBarrier bar   ---------------------------------------------------------------------@@ -115,7 +115,7 @@ withLockTry (Lock m) act = bracket     (tryTakeMVar m)     (\v -> when (isJust v) $ putMVar m ())-    (\v -> if isJust v then fmap Just act else return Nothing)+    (\v -> if isJust v then fmap Just act else pure Nothing)   ---------------------------------------------------------------------@@ -150,7 +150,7 @@  -- | Write a value to become the new value of 'Var'. writeVar :: Var a -> a -> IO ()-writeVar v x = modifyVar_ v $ const $ return x+writeVar v x = modifyVar_ v $ const $ pure x  -- | Modify a 'Var' producing a new value and a return result. modifyVar :: Var a -> (a -> IO (a, b)) -> IO b@@ -195,7 +195,7 @@ signalBarrier :: Partial => Barrier a -> a -> IO () signalBarrier (Barrier var) v = mask_ $ -- use mask so never in an inconsistent state     join $ modifyVar var $ \x -> case x of-        Left bar -> return (Right v, putMVar bar ())+        Left bar -> pure (Right v, putMVar bar ())         Right res -> error "Control.Concurrent.Extra.signalBarrier, attempt to signal a barrier that has already been signaled"  @@ -204,12 +204,12 @@ waitBarrier (Barrier var) = do     x <- readVar var     case x of-        Right res -> return res+        Right res -> pure res         Left bar -> do             readMVar bar             x <- readVar var             case x of-                Right res -> return res+                Right res -> pure res                 Left bar -> error "Control.Concurrent.Extra, internal invariant violated in Barrier"
src/Control/Exception/Extra.hs view
@@ -35,16 +35,16 @@  -- | Fully evaluate an input String. If the String contains embedded exceptions it will produce @\<Exception\>@. ----- > stringException "test"                           == return "test"--- > stringException ("test" ++ undefined)            == return "test<Exception>"--- > stringException ("test" ++ undefined ++ "hello") == return "test<Exception>"--- > stringException ['t','e','s','t',undefined]      == return "test<Exception>"+-- > stringException "test"                           == pure "test"+-- > stringException ("test" ++ undefined)            == pure "test<Exception>"+-- > stringException ("test" ++ undefined ++ "hello") == pure "test<Exception>"+-- > stringException ['t','e','s','t',undefined]      == pure "test<Exception>" stringException :: String -> IO String stringException x = do     r <- try_ $ evaluate $ list [] (\x xs -> x `seq` x:xs) x     case r of-        Left e -> return "<Exception>"-        Right [] -> return []+        Left e -> pure "<Exception>"+        Right [] -> pure []         Right (x:xs) -> (x:) <$> stringException xs  @@ -66,7 +66,7 @@ -- | Ignore any exceptions thrown by the action. -- -- > ignore (print 1)    == print 1--- > ignore (fail "die") == return ()+-- > ignore (fail "die") == pure () ignore :: IO () -> IO () ignore = void . try_ @@ -74,7 +74,7 @@ -- | An 'IO' action that when evaluated calls 'error', in the 'IO' monad. --   Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception with a call stack. ----- > catch (errorIO "Hello") (\(ErrorCall x) -> return x) == return "Hello"+-- > catch (errorIO "Hello") (\(ErrorCall x) -> pure x) == pure "Hello" -- > seq (errorIO "foo") (print 1) == print 1 errorIO :: Partial => String -> IO a errorIO x = withFrozenCallStack $ evaluate $ error x@@ -103,7 +103,7 @@     res <- tryBool p x     case res of         Left _ -> retryBool p (i-1) x-        Right v -> return v+        Right v -> pure v   -- | A version of 'catch' without the 'Exception' context, restricted to 'SomeException',@@ -135,7 +135,7 @@ --   As an example: -- -- @--- readFileExists x == catchBool isDoesNotExistError (readFile \"myfile\") (const $ return \"\")+-- readFileExists x == catchBool isDoesNotExistError (readFile \"myfile\") (const $ pure \"\") -- @ catchBool :: Exception e => (e -> Bool) -> IO a -> (e -> IO a) -> IO a catchBool f a b = catchJust (bool f) a b
src/Control/Monad/Extra.hs view
@@ -30,7 +30,7 @@  -- | Perform some operation on 'Just', given the field inside the 'Just'. ----- > whenJust Nothing  print == return ()+-- > whenJust Nothing  print == pure () -- > whenJust (Just 1) print == print 1 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust mg f = maybe (pure ()) f mg@@ -38,14 +38,14 @@ -- | Like 'whenJust', but where the test can be monadic. whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () -- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative-whenJustM mg f = maybeM (return ()) f mg+whenJustM mg f = maybeM (pure ()) f mg   -- | Like 'when', but return either 'Nothing' if the predicate was 'False', --   of 'Just' with the result of the computation. -- -- > whenMaybe True  (print 1) == fmap Just (print 1)--- > whenMaybe False (print 1) == return Nothing+-- > whenMaybe False (print 1) == pure Nothing whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) whenMaybe b x = if b then Just <$> x else pure Nothing @@ -54,7 +54,7 @@ -- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative whenMaybeM mb x = do     b <- mb-    if b then liftM Just x else return Nothing+    if b then liftM Just x else pure Nothing   -- | The identity function which requires the inner argument to be @()@. Useful for functions@@ -89,7 +89,7 @@  -- | Like 'fold1M' but discards the result. fold1M_ :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m ()-fold1M_ f xs = fold1M f xs >> return ()+fold1M_ f xs = fold1M f xs >> pure ()   -- Data.List for Monad@@ -99,18 +99,18 @@ -- > partitionM (Just . even) [1,2,3] == Just ([2], [1,3]) -- > partitionM (const Nothing) [1,2,3] == Nothing partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM f [] = return ([], [])+partitionM f [] = pure ([], []) partitionM f (x:xs) = do     res <- f x     (as,bs) <- partitionM f xs-    return ([x | res]++as, [x | not res]++bs)+    pure ([x | res]++as, [x | not res]++bs)   -- | A version of 'concatMap' that works with a monadic predicate. concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] {-# INLINE concatMapM #-}-concatMapM op = foldr f (return [])-    where f x xs = do x <- op x; if null x then xs else do xs <- xs; return $ x++xs+concatMapM op = foldr f (pure [])+    where f x xs = do x <- op x; if null x then xs else do xs <- xs; pure $ x++xs  -- | Like 'concatMapM', but has its arguments flipped, so can be used --   instead of the common @fmap concat $ forM@ pattern.@@ -124,8 +124,8 @@ -- | A version of 'mapMaybe' that works with a monadic predicate. mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] {-# INLINE mapMaybeM #-}-mapMaybeM op = foldr f (return [])-    where f x xs = do x <- op x; case x of Nothing -> xs; Just x -> do xs <- xs; return $ x:xs+mapMaybeM op = foldr f (pure [])+    where f x xs = do x <- op x; case x of Nothing -> xs; Just x -> do xs <- xs; pure $ x:xs  -- Looping @@ -145,7 +145,7 @@     res <- act x     case res of         Left x -> loopM act x-        Right v -> return v+        Right v -> pure v  -- | Keep running an operation until it becomes 'False'. As an example: --@@ -164,11 +164,11 @@  -- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m ()-whenM b t = ifM b t (return ())+whenM b t = ifM b t (pure ())  -- | Like 'unless', but where the test can be monadic. unlessM :: Monad m => m Bool -> m () -> m ()-unlessM b f = ifM b (return ()) f+unlessM b f = ifM b (pure ()) f  -- | Like @if@, but where the test can be monadic. ifM :: Monad m => m Bool -> m a -> m a -> m a@@ -186,7 +186,7 @@ -- > Just False ||^ Just True  == Just True -- > Just False ||^ Just False == Just False (||^) :: Monad m => m Bool -> m Bool -> m Bool-(||^) a b = ifM a (return True) b+(||^) a b = ifM a (pure True) b  -- | The lazy '&&' operator lifted to a monad. If the first --   argument evaluates to 'False' the second argument will not@@ -196,7 +196,7 @@ -- > Just True  &&^ Just True  == Just True -- > Just True  &&^ Just False == Just False (&&^) :: Monad m => m Bool -> m Bool -> m Bool-(&&^) a b = ifM a b (return False)+(&&^) a b = ifM a b (pure False)  -- | A version of 'any' lifted to a monad. Retains the short-circuiting behaviour. --@@ -204,7 +204,7 @@ -- > anyM Just [False,False,undefined] == undefined -- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool-anyM p = foldr ((||^) . p) (return False)+anyM p = foldr ((||^) . p) (pure False)  -- | A version of 'all' lifted to a monad. Retains the short-circuiting behaviour. --@@ -212,7 +212,7 @@ -- > allM Just [True,True ,undefined] == undefined -- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) allM :: Monad m => (a -> m Bool) -> [a] -> m Bool-allM p = foldr ((&&^) . p) (return True)+allM p = foldr ((&&^) . p) (pure True)  -- | A version of 'or' lifted to a monad. Retains the short-circuiting behaviour. --@@ -238,9 +238,9 @@ -- > findM (Just . isUpper) "test"             == Just Nothing -- > findM (Just . const True) ["x",undefined] == Just (Just "x") findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM p = foldr (\x -> ifM (p x) (return $ Just x)) (return Nothing)+findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing)  -- | Like 'findM', but also allows you to compute some additional information in the predicate. firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)-firstJustM p [] = return Nothing-firstJustM p (x:xs) = maybeM (firstJustM p xs) (return . Just) (p x)+firstJustM p [] = pure Nothing+firstJustM p (x:xs) = maybeM (firstJustM p xs) (pure . Just) (p x)
src/Data/List/Extra.hs view
@@ -377,10 +377,13 @@     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.+-- | /DEPRECATED/ Use 'nubOrdOn', since this function is _O(n^2)_.+--+--   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.+{-# DEPRECATED nubOn "Use nubOrdOn, since this function is O(n^2)" #-} nubOn :: Eq b => (a -> b) -> [a] -> [a] nubOn f = map snd . nubBy ((==) `on` fst) . map (\x -> let y = f x in y `seq` (y, x))
src/Data/List/NonEmpty/Extra.hs view
@@ -7,11 +7,12 @@     (|:), (|>), snoc,     appendl, appendr,     sortOn, union, unionBy,+    nubOrd, nubOrdBy, nubOrdOn,     maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1     ) where  import           Data.Function-import qualified Data.List as List+import qualified Data.List.Extra as List import           Data.List.NonEmpty  #if __GLASGOW_HASKELL__ <= 802@@ -61,6 +62,25 @@ -- > (1 :| [3, 5, 3]) `union` (4 :| [5, 3, 5, 2]) == 1 :| [3, 5, 3, 4, 2] union :: Eq a => NonEmpty a -> NonEmpty a -> NonEmpty a union = unionBy (==)++-- | @nubOrd@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrd'.+--+-- > Data.List.NonEmpty.Extra.nubOrd (1 :| [2, 3, 3, 4, 1, 2]) == 1 :| [2, 3, 4]+-- > \xs -> Data.List.NonEmpty.Extra.nubOrd xs == Data.List.NonEmpty.Extra.nub xs+nubOrd :: Ord a => NonEmpty a -> NonEmpty a+nubOrd = nubOrdBy compare++-- | @nubOrdBy@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrdBy'.+--+-- > Data.List.NonEmpty.Extra.nubOrdBy (compare `on` Data.List.length) ("a" :| ["test","of","this"]) == "a" :| ["test","of"]+nubOrdBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a+nubOrdBy cmp = fromList . List.nubOrdBy cmp . toList++-- | @nubOrdOn@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrdOn'.+--+-- > Data.List.NonEmpty.Extra.nubOrdOn Data.List.length ("a" :| ["test","of","this"]) == "a" :| ["test","of"]+nubOrdOn :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a+nubOrdOn f = fromList . List.nubOrdOn f . toList  -- | The non-overloaded version of 'union'. unionBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a -> NonEmpty a
src/Extra.hs view
@@ -59,7 +59,7 @@ import Data.Either.Extra import Data.IORef.Extra import Data.List.Extra-import Data.List.NonEmpty.Extra hiding (cons, snoc, sortOn, union, unionBy)+import Data.List.NonEmpty.Extra hiding (cons, snoc, sortOn, union, unionBy, nubOrd, nubOrdBy, nubOrdOn) import Data.Tuple.Extra import Data.Version.Extra import Numeric.Extra
src/System/Directory/Extra.hs view
@@ -52,12 +52,12 @@ -- -- > 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+-- > let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir </>) as; res <- op dir; pure $ 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-    return $ sort [dir </> x | x <- xs, not $ all (== '.') x]+    pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]   -- | Like 'listContents', but only returns the directories in a directory, not the files.@@ -81,21 +81,21 @@ -- -- > listTest listFilesRecursive ["bar.txt","zoo","foo" </> "baz.txt"] ["bar.txt","zoo","foo" </> "baz.txt"] listFilesRecursive :: FilePath -> IO [FilePath]-listFilesRecursive = listFilesInside (const $ return True)+listFilesRecursive = listFilesInside (const $ pure 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)+-- > listTest (listFilesInside $ pure . 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"] []+-- > listTest (listFilesInside $ const $ pure False) ["bar.txt"] [] listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]-listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (return []) $ do+listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do     (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir     rest <- concatMapM (listFilesInside test) dirs-    return $ files ++ rest+    pure $ files ++ rest   -- | Create a directory with permissions so that only the current user can view it.
src/System/IO/Extra.hs view
@@ -66,7 +66,7 @@ hGetContents' h = do     s <- hGetContents h     void $ evaluate $ length s-    return s+    pure s  -- | 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.@@ -112,7 +112,7 @@  -- | Capture the 'stdout' and 'stderr' of a computation. ----- > captureOutput (print 1) == return ("1\n",())+-- > captureOutput (print 1) == pure ("1\n",()) captureOutput :: IO a -> IO (String, a) captureOutput act = withTempFile $ \file ->     withFile file ReadWriteMode $ \h -> do@@ -120,7 +120,7 @@             hClose h             act         out <- readFile' file-        return (out, res)+        pure (out, res)     where         clone out h act = do             buf <- hGetBuffering out@@ -166,13 +166,13 @@ newTempFileWithin tmpdir = do         file <- create         del <- once $ ignore $ removeFile file-        return (file, del)+        pure (file, del)     where         create = do             val <- tempUnique             (file, h) <- retryBool (\(_ :: IOError) -> True) 5 $ openTempFile tmpdir $ "extra-file-" ++ show val ++ "-"             hClose h-            return file+            pure file   -- | Create a temporary file in the temporary directory. The file will be deleted@@ -180,9 +180,9 @@ --   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 doesFileExist == pure True+-- > (doesFileExist =<< withTempFile pure) == pure False+-- > withTempFile readFile' == pure "" withTempFile :: (FilePath -> IO a) -> IO a withTempFile act = do     (file, del) <- newTempFile@@ -200,22 +200,22 @@ newTempDirWithin tmpdir = do         dir <- retryBool (\(_ :: IOError) -> True) 5 $ create tmpdir         del <- once $ ignore $ removeDirectoryRecursive dir-        return (dir, del)+        pure (dir, del)     where         create tmpdir = do             v <- tempUnique             let dir = tmpdir </> "extra-dir-" ++ show v             catchBool isAlreadyExistsError-                (createDirectoryPrivate dir >> return dir) $+                (createDirectoryPrivate dir >> pure dir) $                 \_ -> create tmpdir   -- | 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 doesDirectoryExist == pure True+-- > (doesDirectoryExist =<< withTempDir pure) == pure False+-- > withTempDir listFiles == pure [] withTempDir :: (FilePath -> IO a) -> IO a withTempDir act = do     (dir,del) <- newTempDir@@ -235,8 +235,8 @@             r1 <- hGetBuf h1 b1 bufsz             r2 <- hGetBuf h2 b2 bufsz             if r1 == 0-                then return $ r2 == 0-                else return (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2+                then pure $ r2 == 0+                else pure (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2           bufeq b1 b2 s = (==0) <$> memcmp b1 b2 (fromIntegral s)           withb = allocaBytesAligned bufsz 4096           bufsz = 64*1024
src/System/Process/Extra.hs view
@@ -40,4 +40,4 @@     (res,out) <- systemOutput x     when (res /= ExitSuccess) $         error $ "Failed when running system command: " ++ x-    return out+    pure out
src/System/Time/Extra.hs view
@@ -26,18 +26,18 @@  -- | Sleep for a number of seconds. ----- > fmap (round . fst) (duration $ sleep 1) == return 1+-- > fmap (round . fst) (duration $ sleep 1) == pure 1 sleep :: Seconds -> IO () sleep = loopM $ \s ->     -- important to handle both overflow and underflow vs Int     if s < 0 then-        return $ Right ()+        pure $ Right ()     else if s > 2000 then do         threadDelay 2000000000 -- 2000 * 1e6-        return $ Left $ s - 2000+        pure $ Left $ s - 2000     else do         threadDelay $ ceiling $ s * 1000000-        return $ Right ()+        pure $ Right ()   -- An internal type that is thrown as a dynamic exception to@@ -52,19 +52,19 @@ --   overflows the bounds of an 'Int'. In addition, the bug that negative --   timeouts run for ever has been fixed. ----- > timeout (-3) (print 1) == return Nothing+-- > timeout (-3) (print 1) == pure Nothing -- > timeout 0.1  (print 1) == fmap Just (print 1)--- > do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1--- > timeout 0.1  (sleep 2 >> print 1) == return Nothing+-- > do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; pure $ t < 1+-- > timeout 0.1  (sleep 2 >> print 1) == pure Nothing timeout :: Seconds -> IO a -> IO (Maybe a) -- Copied from GHC with a few tweaks. timeout n f-    | n <= 0 = return Nothing+    | n <= 0 = pure Nothing     | otherwise = do         pid <- myThreadId         ex  <- fmap Timeout newUnique         handleBool (== ex)-                   (const $ return Nothing)+                   (const $ pure Nothing)                    (bracket (forkIOWithUnmask $ \unmask -> unmask $ sleep n >> throwTo pid ex)                             killThread                             (\_ -> fmap Just f))@@ -90,13 +90,13 @@ -- | Call once to start, then call repeatedly to get the elapsed time since the first call. --   The time is guaranteed to be monotonic. This function is robust to system time changes. ----- > do f <- offsetTime; xs <- replicateM 10 f; return $ xs == sort xs+-- > do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs offsetTime :: IO (IO Seconds) offsetTime = do     start <- time-    return $ do+    pure $ do         end <- time-        return $ 1e-9 * fromIntegral (toNanoSecs $ end - start)+        pure $ 1e-9 * fromIntegral (toNanoSecs $ end - start)     where time = getTime Monotonic  {-# DEPRECATED offsetTimeIncrease "Use 'offsetTime' instead, which is guaranteed to always increase." #-}@@ -107,10 +107,10 @@  -- | Record how long a computation takes in 'Seconds'. ----- > do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.5+-- > do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5 duration :: IO a -> IO (Seconds, a) duration act = do     time <- offsetTime     res <- act     time <- time-    return (time, res)+    pure (time, res)
test/TestCustom.hs view
@@ -16,14 +16,14 @@      testRaw "withTempFile" $ do         xs <- replicateM 4 $ onceFork $ do-            replicateM_ 100 $ withTempFile (const $ return ())+            replicateM_ 100 $ withTempFile (const $ pure ())             putChar '.'         sequence_ xs         putStrLn "done"      testRaw "withTempDir" $ do         xs <- replicateM 4 $ onceFork $ do-            replicateM_ 100 $ withTempDir (const $ return ())+            replicateM_ 100 $ withTempDir (const $ pure ())             putChar '.'         sequence_ xs         putStrLn "done"
test/TestGen.hs view
@@ -4,30 +4,33 @@ {-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-} module TestGen(tests) where import TestUtil+import qualified Data.List+import qualified Data.List.NonEmpty.Extra+import Test.QuickCheck.Instances.Semigroup () default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () tests = do     let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2-    testGen "\\(x :: IO Int) -> void (once x) == return ()" $ \(x :: IO Int) -> void (once x) == return ()+    testGen "\\(x :: IO Int) -> void (once x) == pure ()" $ \(x :: IO Int) -> void (once x) == pure ()     testGen "\\(x :: IO Int) -> join (once x) == x" $ \(x :: IO Int) -> join (once x) == x     testGen "\\(x :: IO Int) -> (do y <- once x; y; y) == x" $ \(x :: IO Int) -> (do y <- once x; y; y) == x     testGen "\\(x :: IO Int) -> (do y <- once x; y ||| y) == x" $ \(x :: IO Int) -> (do y <- once x; y ||| y) == x     testGen "\\(x :: IO Int) -> join (onceFork x) == x" $ \(x :: IO Int) -> join (onceFork x) == x     testGen "\\(x :: IO Int) -> (do a <- onceFork x; a; a) == x" $ \(x :: IO Int) -> (do a <- onceFork x; a; a) == x-    testGen "stringException \"test\"                           == return \"test\"" $ stringException "test"                           == return "test"-    testGen "stringException (\"test\" ++ undefined)            == return \"test<Exception>\"" $ stringException ("test" ++ undefined)            == return "test<Exception>"-    testGen "stringException (\"test\" ++ undefined ++ \"hello\") == return \"test<Exception>\"" $ stringException ("test" ++ undefined ++ "hello") == return "test<Exception>"-    testGen "stringException ['t','e','s','t',undefined]      == return \"test<Exception>\"" $ stringException ['t','e','s','t',undefined]      == return "test<Exception>"+    testGen "stringException \"test\"                           == pure \"test\"" $ stringException "test"                           == pure "test"+    testGen "stringException (\"test\" ++ undefined)            == pure \"test<Exception>\"" $ stringException ("test" ++ undefined)            == pure "test<Exception>"+    testGen "stringException (\"test\" ++ undefined ++ \"hello\") == pure \"test<Exception>\"" $ stringException ("test" ++ undefined ++ "hello") == pure "test<Exception>"+    testGen "stringException ['t','e','s','t',undefined]      == pure \"test<Exception>\"" $ stringException ['t','e','s','t',undefined]      == pure "test<Exception>"     testGen "ignore (print 1)    == print 1" $ ignore (print 1)    == print 1-    testGen "ignore (fail \"die\") == return ()" $ ignore (fail "die") == return ()-    testGen "catch (errorIO \"Hello\") (\\(ErrorCall x) -> return x) == return \"Hello\"" $ catch (errorIO "Hello") (\(ErrorCall x) -> return x) == return "Hello"+    testGen "ignore (fail \"die\") == pure ()" $ ignore (fail "die") == pure ()+    testGen "catch (errorIO \"Hello\") (\\(ErrorCall x) -> pure x) == pure \"Hello\"" $ catch (errorIO "Hello") (\(ErrorCall x) -> pure x) == pure "Hello"     testGen "seq (errorIO \"foo\") (print 1) == print 1" $ seq (errorIO "foo") (print 1) == print 1     testGen "retry 1 (print \"x\")  == print \"x\"" $ retry 1 (print "x")  == print "x"     testGen "retry 3 (fail \"die\") == fail \"die\"" $ retry 3 (fail "die") == fail "die"-    testGen "whenJust Nothing  print == return ()" $ whenJust Nothing  print == return ()+    testGen "whenJust Nothing  print == pure ()" $ whenJust Nothing  print == pure ()     testGen "whenJust (Just 1) print == print 1" $ whenJust (Just 1) print == print 1     testGen "whenMaybe True  (print 1) == fmap Just (print 1)" $ whenMaybe True  (print 1) == fmap Just (print 1)-    testGen "whenMaybe False (print 1) == return Nothing" $ whenMaybe False (print 1) == return Nothing+    testGen "whenMaybe False (print 1) == pure Nothing" $ whenMaybe False (print 1) == pure Nothing     testGen "\\(x :: Maybe ()) -> unit x == x" $ \(x :: Maybe ()) -> unit x == x     testGen "fold1M (\\x y -> Just x) [] == undefined" $ erroneous $ fold1M (\x y -> Just x) []     testGen "fold1M (\\x y -> Just $ x + y) [1, 2, 3] == Just 6" $ fold1M (\x y -> Just $ x + y) [1, 2, 3] == Just 6@@ -243,6 +246,10 @@     testGen "appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5]" $ appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5]     testGen "appendr [1,2,3] (4 :| [5]) == 1 :| [2,3,4,5]" $ appendr [1,2,3] (4 :| [5]) == 1 :| [2,3,4,5]     testGen "(1 :| [3, 5, 3]) `union` (4 :| [5, 3, 5, 2]) == 1 :| [3, 5, 3, 4, 2]" $ (1 :| [3, 5, 3]) `union` (4 :| [5, 3, 5, 2]) == 1 :| [3, 5, 3, 4, 2]+    testGen "Data.List.NonEmpty.Extra.nubOrd (1 :| [2, 3, 3, 4, 1, 2]) == 1 :| [2, 3, 4]" $ Data.List.NonEmpty.Extra.nubOrd (1 :| [2, 3, 3, 4, 1, 2]) == 1 :| [2, 3, 4]+    testGen "\\xs -> Data.List.NonEmpty.Extra.nubOrd xs == Data.List.NonEmpty.Extra.nub xs" $ \xs -> Data.List.NonEmpty.Extra.nubOrd xs == Data.List.NonEmpty.Extra.nub xs+    testGen "Data.List.NonEmpty.Extra.nubOrdBy (compare `on` Data.List.length) (\"a\" :| [\"test\",\"of\",\"this\"]) == \"a\" :| [\"test\",\"of\"]" $ Data.List.NonEmpty.Extra.nubOrdBy (compare `on` Data.List.length) ("a" :| ["test","of","this"]) == "a" :| ["test","of"]+    testGen "Data.List.NonEmpty.Extra.nubOrdOn Data.List.length (\"a\" :| [\"test\",\"of\",\"this\"]) == \"a\" :| [\"test\",\"of\"]" $ Data.List.NonEmpty.Extra.nubOrdOn Data.List.length ("a" :| ["test","of","this"]) == "a" :| ["test","of"]     testGen "first succ (1,\"test\") == (2,\"test\")" $ first succ (1,"test") == (2,"test")     testGen "second reverse (1,\"test\") == (1,\"tset\")" $ second reverse (1,"test") == (1,"tset")     testGen "firstM (\\x -> [x-1, x+1]) (1,\"test\") == [(0,\"test\"),(2,\"test\")]" $ firstM (\x -> [x-1, x+1]) (1,"test") == [(0,"test"),(2,"test")]@@ -259,38 +266,38 @@     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+    let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir </>) as; res <- op dir; pure $ 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 listDirectories [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"foo\"]" $ listTest listDirectories ["bar.txt","foo/baz.txt","zoo"] ["foo"]     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 "listTest (listFilesInside $ pure . not . isPrefixOf \".\" . takeFileName)    [\"bar.txt\",\"foo\" </> \"baz.txt\",\".foo\" </> \"baz2.txt\", \"zoo\"] [\"bar.txt\",\"zoo\",\"foo\" </> \"baz.txt\"]" $ listTest (listFilesInside $ pure . not . isPrefixOf "." . takeFileName)    ["bar.txt","foo" </> "baz.txt",".foo" </> "baz2.txt", "zoo"] ["bar.txt","zoo","foo" </> "baz.txt"]+    testGen "listTest (listFilesInside $ const $ pure False) [\"bar.txt\"] []" $ listTest (listFilesInside $ const $ pure False) ["bar.txt"] []     testGen "isWindows == (os == \"mingw32\")" $ isWindows == (os == "mingw32")     testGen "\\(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \\file -> do writeFile file s; readFile' file" $ \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file     testGen "\\s -> withTempFile $ \\file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file" $ \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file     testGen "\\(ASCIIString s) -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file-    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 "captureOutput (print 1) == pure (\"1\\n\",())" $ captureOutput (print 1) == pure ("1\n",())+    testGen "withTempFile doesFileExist == pure True" $ withTempFile doesFileExist == pure True+    testGen "(doesFileExist =<< withTempFile pure) == pure False" $ (doesFileExist =<< withTempFile pure) == pure False+    testGen "withTempFile readFile' == pure \"\"" $ withTempFile readFile' == pure ""+    testGen "withTempDir doesDirectoryExist == pure True" $ withTempDir doesDirectoryExist == pure True+    testGen "(doesDirectoryExist =<< withTempDir pure) == pure False" $ (doesDirectoryExist =<< withTempDir pure) == pure False+    testGen "withTempDir listFiles == pure []" $ withTempDir listFiles == pure []     testGen "fileEq \"does_not_exist1\" \"does_not_exist2\" == undefined" $ erroneousIO $ fileEq "does_not_exist1" "does_not_exist2"     testGen "fileEq \"does_not_exist\" \"does_not_exist\" == undefined" $ erroneousIO $ fileEq "does_not_exist" "does_not_exist"     testGen "withTempFile $ \\f1 -> fileEq \"does_not_exist\" f1 == undefined" $ erroneousIO $ withTempFile $ \f1 -> fileEq "does_not_exist" f1     testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> fileEq f1 f2" $ withTempFile $ \f1 -> withTempFile $ \f2 -> fileEq f1 f2     testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> writeFile f1 \"a\" >> writeFile f2 \"a\" >> fileEq f1 f2" $ withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "a" >> fileEq f1 f2     testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> writeFile f1 \"a\" >> writeFile f2 \"b\" >> notM (fileEq f1 f2)" $ withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "b" >> notM (fileEq f1 f2)-    testGen "fmap (round . fst) (duration $ sleep 1) == return 1" $ fmap (round . fst) (duration $ sleep 1) == return 1-    testGen "timeout (-3) (print 1) == return Nothing" $ timeout (-3) (print 1) == return Nothing+    testGen "fmap (round . fst) (duration $ sleep 1) == pure 1" $ fmap (round . fst) (duration $ sleep 1) == pure 1+    testGen "timeout (-3) (print 1) == pure Nothing" $ timeout (-3) (print 1) == pure Nothing     testGen "timeout 0.1  (print 1) == fmap Just (print 1)" $ timeout 0.1  (print 1) == fmap Just (print 1)-    testGen "do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1" $ do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1-    testGen "timeout 0.1  (sleep 2 >> print 1) == return Nothing" $ timeout 0.1  (sleep 2 >> print 1) == return Nothing+    testGen "do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; pure $ t < 1" $ do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; pure $ t < 1+    testGen "timeout 0.1  (sleep 2 >> print 1) == pure Nothing" $ timeout 0.1  (sleep 2 >> print 1) == pure Nothing     testGen "showDuration 3.435   == \"3.44s\"" $ showDuration 3.435   == "3.44s"     testGen "showDuration 623.8   == \"10m24s\"" $ showDuration 623.8   == "10m24s"     testGen "showDuration 62003.8 == \"17h13m\"" $ showDuration 62003.8 == "17h13m"     testGen "showDuration 1e8     == \"27777h47m\"" $ showDuration 1e8     == "27777h47m"-    testGen "do f <- offsetTime; xs <- replicateM 10 f; return $ xs == sort xs" $ do f <- offsetTime; xs <- replicateM 10 f; return $ xs == sort xs-    testGen "do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.5" $ do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.5+    testGen "do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs" $ do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs+    testGen "do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5" $ do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5
test/TestUtil.hs view
@@ -46,7 +46,7 @@ testGen msg prop = testRaw msg $ do     r <- quickCheckResult prop     case r of-        Success{} -> return ()+        Success{} -> pure ()         _ -> errorIO "Test failed"  testRaw :: String -> IO () -> IO ()@@ -87,7 +87,7 @@     a == b = unsafePerformIO $ do         a <- try_ $ captureOutput a         b <- try_ $ captureOutput b-        if a == b then return True else+        if a == b then pure True else             error $ show ("IO values not equal", a, b)  instance Show (IO a) where@@ -96,10 +96,10 @@ instance Arbitrary a => Arbitrary (IO a) where     arbitrary = do         (prnt :: Maybe Int, thrw :: Maybe Int, res) <- arbitrary-        return $ do+        pure $ do             whenJust prnt print             whenJust thrw (fail . show)-            return res+            pure res  instance Eq SomeException where     a == b = show a == show b