Hello community, here is the log from the commit of package ghc-extra for openSUSE:Leap:15.2 checked in at 2020-05-21 12:58:22 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Leap:15.2/ghc-extra (Old) and /work/SRC/openSUSE:Leap:15.2/.ghc-extra.new.2738 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-extra" Thu May 21 12:58:22 2020 rev:13 rq:805464 version:1.7.1 Changes: -------- --- /work/SRC/openSUSE:Leap:15.2/ghc-extra/ghc-extra.changes 2020-03-13 10:56:51.676412695 +0100 +++ /work/SRC/openSUSE:Leap:15.2/.ghc-extra.new.2738/ghc-extra.changes 2020-05-21 12:58:23.250670677 +0200 @@ -1,0 +2,13 @@ +Wed May 6 06:54:11 UTC 2020 - psim...@suse.com + +- Update extra to version 1.7.1. + 1.7.1, released 2020-03-10 + Add NOINLINE to errorIO to work around a GHC 8.4 bug + 1.7, released 2020-03-05 + * #40, delete deprecated function for + * zipFrom now truncates lists, rather than error, just like zip + 1.6.21, released 2020-03-02 + #54, deprecate nubOn since its O(n^2). Use nubOrdOn + #53, add some nub functions to NonEmpty + +------------------------------------------------------------------- Old: ---- extra-1.6.20.tar.gz New: ---- extra-1.7.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-extra.spec ++++++ --- /var/tmp/diff_new_pack.DOaOlV/_old 2020-05-21 12:58:23.586671409 +0200 +++ /var/tmp/diff_new_pack.DOaOlV/_new 2020-05-21 12:58:23.590671417 +0200 @@ -19,7 +19,7 @@ %global pkg_name extra %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.6.20 +Version: 1.7.1 Release: 0 Summary: Extra functions I use License: BSD-3-Clause @@ -36,6 +36,7 @@ BuildRequires: ghc-unix-devel %if %{with tests} BuildRequires: ghc-QuickCheck-devel +BuildRequires: ghc-quickcheck-instances-devel %endif %description ++++++ extra-1.6.20.tar.gz -> extra-1.7.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/CHANGES.txt new/extra-1.7.1/CHANGES.txt --- old/extra-1.6.20/CHANGES.txt 2020-02-16 14:17:13.000000000 +0100 +++ new/extra-1.7.1/CHANGES.txt 2020-03-10 23:59:31.000000000 +0100 @@ -1,5 +1,13 @@ Changelog for Extra +1.7.1, released 2020-03-10 + Add NOINLINE to errorIO to work around a GHC 8.4 bug +1.7, released 2020-03-05 +* #40, delete deprecated function for +* zipFrom now truncates lists, rather than error, just like zip +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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/Generate.hs new/extra-1.7.1/Generate.hs --- old/extra-1.6.20/Generate.hs 2019-04-22 20:25:59.000000000 +0200 +++ new/extra-1.7.1/Generate.hs 2020-03-02 10:33:57.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/extra.cabal new/extra-1.7.1/extra.cabal --- old/extra-1.6.20/extra.cabal 2020-02-16 14:17:19.000000000 +0100 +++ new/extra-1.7.1/extra.cabal 2020-03-10 23:59:36.000000000 +0100 @@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: extra -version: 1.6.20 +version: 1.7.1 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/Control/Concurrent/Extra.hs new/extra-1.7.1/src/Control/Concurrent/Extra.hs --- old/extra-1.6.20/src/Control/Concurrent/Extra.hs 2020-02-16 13:45:13.000000000 +0100 +++ new/extra-1.7.1/src/Control/Concurrent/Extra.hs 2020-02-28 10:29:17.000000000 +0100 @@ -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" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/Control/Exception/Extra.hs new/extra-1.7.1/src/Control/Exception/Extra.hs --- old/extra-1.6.20/src/Control/Exception/Extra.hs 2019-08-23 14:45:24.000000000 +0200 +++ new/extra-1.7.1/src/Control/Exception/Extra.hs 2020-03-09 22:13:41.000000000 +0100 @@ -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,8 +74,9 @@ -- | 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 +{-# NOINLINE errorIO #-} -- otherwise GHC 8.4.1 seems to get upset errorIO :: Partial => String -> IO a errorIO x = withFrozenCallStack $ evaluate $ error x @@ -103,7 +104,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 +136,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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/Control/Monad/Extra.hs new/extra-1.7.1/src/Control/Monad/Extra.hs --- old/extra-1.6.20/src/Control/Monad/Extra.hs 2020-02-16 13:46:02.000000000 +0100 +++ new/extra-1.7.1/src/Control/Monad/Extra.hs 2020-02-28 10:30:04.000000000 +0100 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/Data/List/Extra.hs new/extra-1.7.1/src/Data/List/Extra.hs --- old/extra-1.6.20/src/Data/List/Extra.hs 2020-02-16 13:43:54.000000000 +0100 +++ new/extra-1.7.1/src/Data/List/Extra.hs 2020-03-05 10:10:35.000000000 +0100 @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, BangPatterns, ConstraintKinds #-} +{-# LANGUAGE TupleSections, ConstraintKinds #-} -- | This module extends "Data.List" with extra functions of a similar nature. -- The package also exports the existing "Data.List" functions. @@ -29,7 +29,7 @@ nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, allSame, anySame, - repeatedly, for, firstJust, + repeatedly, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, @@ -59,13 +59,6 @@ where (b, as') = f as --- | /DEPRECATED/ Use @flip map@ directly, since this function clashes with @Data.Traversable.for@. --- --- Flipped version of 'map'. -{-# DEPRECATED for "Use flip map directly, since this function clashes with Data.Traversable.for" #-} -for :: [a] -> (a -> b) -> [b] -for = flip map - -- | Are two lists disjoint, with no elements in common. -- -- > disjoint [1,2,3] [4,5] == True @@ -211,20 +204,18 @@ -- Never truncates the output - raises an error if the enumeration runs out. -- -- > \i xs -> zip [i..] xs == zipFrom i xs --- > zipFrom False [1..3] == undefined -zipFrom :: (Partial, Enum a) => a -> [b] -> [(a, b)] +-- > zipFrom False [1..3] == [(False,1),(True, 2)] +zipFrom :: Enum a => a -> [b] -> [(a, b)] zipFrom = zipWithFrom (,) -- | 'zipFrom' generalised to any combining operation. -- Never truncates the output - raises an error if the enumeration runs out. -- -- > \i xs -> zipWithFrom (,) i xs == zipFrom i xs -zipWithFrom :: (Partial, Enum a) => (a -> b -> c) -> a -> [b] -> [c] -zipWithFrom f a xs = go a xs - where - -- if we aren't strict in the accumulator, it's highly like to be a space leak - go !a [] = [] - go !a (x:xs) = f a x : go (succ a) xs +zipWithFrom :: Enum a => (a -> b -> c) -> a -> [b] -> [c] +-- would love to deforest the intermediate [a..] list +-- but would require Bounded and Eq as well, so better go for simplicit +zipWithFrom f a = zipWith f [a..] -- | A merging of 'unzip' and 'concat'. @@ -377,10 +368,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)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/Data/List/NonEmpty/Extra.hs new/extra-1.7.1/src/Data/List/NonEmpty/Extra.hs --- old/extra-1.6.20/src/Data/List/NonEmpty/Extra.hs 2019-04-22 20:25:59.000000000 +0200 +++ new/extra-1.7.1/src/Data/List/NonEmpty/Extra.hs 2020-03-02 10:33:57.000000000 +0100 @@ -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 @@ -62,6 +63,25 @@ 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 unionBy eq xs ys = fromList $ List.unionBy eq (toList xs) (toList ys) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/Extra.hs new/extra-1.7.1/src/Extra.hs --- old/extra-1.6.20/src/Extra.hs 2020-02-16 12:34:30.000000000 +0100 +++ new/extra-1.7.1/src/Extra.hs 2020-03-05 10:10:08.000000000 +0100 @@ -23,7 +23,7 @@ writeIORef', atomicWriteIORef', atomicModifyIORef_, atomicModifyIORef'_, -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. - lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, headDef, lastDef, notNull, list, unsnoc, cons, snoc, drop1, dropEnd1, mconcatMap, enumerate, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, + lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, headDef, lastDef, notNull, list, unsnoc, cons, snoc, drop1, dropEnd1, mconcatMap, enumerate, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, allSame, anySame, repeatedly, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, replace, merge, mergeBy, -- * Data.List.NonEmpty.Extra -- | Extra functions available in @"Data.List.NonEmpty.Extra"@. (|:), (|>), appendl, appendr, maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1, @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/System/Directory/Extra.hs new/extra-1.7.1/src/System/Directory/Extra.hs --- old/extra-1.6.20/src/System/Directory/Extra.hs 2018-05-24 16:54:16.000000000 +0200 +++ new/extra-1.7.1/src/System/Directory/Extra.hs 2020-02-28 10:28:02.000000000 +0100 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/System/IO/Extra.hs new/extra-1.7.1/src/System/IO/Extra.hs --- old/extra-1.6.20/src/System/IO/Extra.hs 2018-12-07 12:00:59.000000000 +0100 +++ new/extra-1.7.1/src/System/IO/Extra.hs 2020-02-28 10:28:02.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/System/Process/Extra.hs new/extra-1.7.1/src/System/Process/Extra.hs --- old/extra-1.6.20/src/System/Process/Extra.hs 2018-05-23 08:09:48.000000000 +0200 +++ new/extra-1.7.1/src/System/Process/Extra.hs 2020-02-28 10:28:02.000000000 +0100 @@ -40,4 +40,4 @@ (res,out) <- systemOutput x when (res /= ExitSuccess) $ error $ "Failed when running system command: " ++ x - return out + pure out diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/src/System/Time/Extra.hs new/extra-1.7.1/src/System/Time/Extra.hs --- old/extra-1.6.20/src/System/Time/Extra.hs 2018-09-04 22:17:51.000000000 +0200 +++ new/extra-1.7.1/src/System/Time/Extra.hs 2020-02-28 10:28:02.000000000 +0100 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/test/TestCustom.hs new/extra-1.7.1/test/TestCustom.hs --- old/extra-1.6.20/test/TestCustom.hs 2017-11-24 11:40:53.000000000 +0100 +++ new/extra-1.7.1/test/TestCustom.hs 2020-02-28 10:28:02.000000000 +0100 @@ -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" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/test/TestGen.hs new/extra-1.7.1/test/TestGen.hs --- old/extra-1.6.20/test/TestGen.hs 2020-02-16 12:34:30.000000000 +0100 +++ new/extra-1.7.1/test/TestGen.hs 2020-03-05 09:43:16.000000000 +0100 @@ -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 @@ -125,7 +128,7 @@ testGen "\\i xs -> uncurry (++) (splitAt i xs) == xs" $ \i xs -> uncurry (++) (splitAt i xs) == xs testGen "\\i xs -> splitAtEnd i xs == (dropEnd i xs, takeEnd i xs)" $ \i xs -> splitAtEnd i xs == (dropEnd i xs, takeEnd i xs) testGen "\\i xs -> zip [i..] xs == zipFrom i xs" $ \i xs -> zip [i..] xs == zipFrom i xs - testGen "zipFrom False [1..3] == undefined" $ erroneous $ zipFrom False [1..3] + testGen "zipFrom False [1..3] == [(False,1),(True, 2)]" $ zipFrom False [1..3] == [(False,1),(True, 2)] testGen "\\i xs -> zipWithFrom (,) i xs == zipFrom i xs" $ \i xs -> zipWithFrom (,) i xs == zipFrom i xs testGen "concatUnzip [(\"a\",\"AB\"),(\"bc\",\"C\")] == (\"abc\",\"ABC\")" $ concatUnzip [("a","AB"),("bc","C")] == ("abc","ABC") testGen "concatUnzip3 [(\"a\",\"AB\",\"\"),(\"bc\",\"C\",\"123\")] == (\"abc\",\"ABC\",\"123\")" $ concatUnzip3 [("a","AB",""),("bc","C","123")] == ("abc","ABC","123") @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/extra-1.6.20/test/TestUtil.hs new/extra-1.7.1/test/TestUtil.hs --- old/extra-1.6.20/test/TestUtil.hs 2020-02-11 23:14:17.000000000 +0100 +++ new/extra-1.7.1/test/TestUtil.hs 2020-02-28 10:28:02.000000000 +0100 @@ -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