extra 1.6.21 → 1.8.1

raw patch · 23 files changed

Files

• CHANGES.txt +63/−1
• Generate.hs +23/−9
• LICENSE +1/−1
• README.md +6/−2
• extra.cabal +7/−7
• src/Control/Concurrent/Extra.hs +36/−23
• src/Control/Exception/Extra.hs +9/−1
• src/Control/Monad/Extra.hs +84/−3
• src/Data/Foldable/Extra.hs +71/−0
• src/Data/List/Extra.hs +232/−55
• src/Data/List/NonEmpty/Extra.hs +65/−2
• src/Data/Monoid/Extra.hs +17/−0
• src/Data/Tuple/Extra.hs +23/−3
• src/Data/Typeable/Extra.hs +1/−1
• src/Extra.hs +10/−6
• src/System/Environment/Extra.hs +2/−3
• src/System/IO/Extra.hs +7/−1
• src/System/Time/Extra.hs +4/−3
• src/Text/Read/Extra.hs +1/−1
• test/Test.hs +1/−0
• test/TestCustom.hs +20/−3
• test/TestGen.hs +45/−15
• test/TestUtil.hs +3/−5

@@ -1,5 +1,67 @@-Changelog for Extra+Changelog for Extra (* = breaking change) +1.8.1, released 2025-11-23+    #118, future proof for GHC 9.16 gaining nubOrd and nubOrdBy+    Test with GHC 9.12+1.8, released 2024-10-19+    #109, add guarded to lift predicates into Alternatives+*   #112, make Data.List.Extra.compareLength work on list/int only+    #112, add compareLength to List.NonEmpty and Foldable+1.7.16, released 2024-05-11+    Fix to actually work with GHC 9.10+1.7.15, released 2024-05-10+    #111, work with GHC 9.10+    Test with GHC 9.8+1.7.14, released 2023-07-01+    #106, add compatibility with GHC 9.7+    #103, future-proof against addition of Data.List.unsnoc+1.7.13, released 2023-04-22+    #102, add mwhen :: Monoid a => Bool -> a -> a+    #99, make replace with an empty from intersperse the replacement+    #101, future-proof against addition of Data.List.!?+1.7.12, released 2022-09-02+    #98, make both lazy in its argument+    #98, make first3,second3,third3 lazy in their argument+    #98, make firstM,secondM lazy in their argument+    #86, add notNull for Foldable+1.7.11, released 2022-08-21+    #95, add List.repeatedlyNE and NonEmpty.repeatedly+    #94, add groupOnKey+    #91, add foldl1' to NonEmpty+1.7.10, released 2021-08-29+    #81, add assertIO function+    #85, add !? to do !! list indexing returning a Maybe+    #80, add strict Var functions modifyVar', modifyVar_', writeVar'+1.7.9, released 2020-12-19+    #72, add pureIf+    #73, make takeEnd, dropEnd, splitAtEnd: return immediately if i <= 0+    #71, add compareLength and comparingLength+1.7.8, released 2020-09-12+    #68, make sure Data.Foldable.Extra is exposed+1.7.7, released 2020-08-25+    #67, defer to System.IO readFile', hGetContents' in GHC 9.0+1.7.6, released 2020-08-21+    #66, add lots of functions to Data.Foldable.Extra (anyM etc)+1.7.5, released 2020-08-12+    #65, add Data.Foldable.Extra+    #65, add sum', product', sumOn' and productOn'+1.7.4, released 2020-07-15+    #59, add whileJustM and untilJustM+    #61, optimise nubOrd (10% or so)+    Add first3, second3, third3+1.7.3, released 2020-05-30+    #58, add disjointOrd and disjointOrdBy+1.7.2, released 2020-05-25+    #56, add zipWithLongest+    #57, make duration in MonadIO+    Simplify and optimise Barrier+    Mark modules that are empty as DEPRECATED+    Remove support for GHC 7.10+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,5 +1,9 @@ -- This module generates the files src/Extra.hs and test/TestGen.hs.--- Either call "runhaskell Generate" or start "ghci" and use ":generate".+-- Typical usage is run:+--+-- * `cabal test` to install the necessary packages+-- * `cabal exec ghci` to get into GHCi+-- * `:go` or `:generate` to run this generator  module Generate(main) where @@ -19,12 +23,12 @@ main = do     src <- readFile "extra.cabal"     let mods = filter (isSuffixOf ".Extra") $ map trim $ lines src-    ifaces <- forM mods $ \mod -> do+    ifaces <- forM (mods \\ exclude) $ \mod -> do         src <- readFile $ joinPath ("src" : split (== '.') mod) <.> "hs"         let funcs = filter validIdentifier $ takeWhile (/= "where") $                     words $ replace "," " " $ drop1 $ dropWhile (/= '(') $                     unlines $ filter (\x -> not $ any (`isPrefixOf` trim x) ["--","#"]) $ lines src-        let tests = mapMaybe (stripPrefix "-- > ") $ lines src+        let tests = if mod `elem` excludeTests then [] else mapMaybe (stripPrefix "-- > ") $ lines src         pure (mod, funcs, tests)     writeFileBinaryChanged "src/Extra.hs" $ unlines $         ["-- GENERATED CODE - DO NOT MODIFY"@@ -46,11 +50,11 @@         ["-- GENERATED CODE - DO NOT MODIFY"         ,"-- See Generate.hs for details of how to generate"         ,""-        ,"{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-}"+        ,"{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, TypeApplications, ViewPatterns #-}"+        ,"{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}"         ,"module TestGen(tests) where"         ,"import TestUtil"-        ,"import qualified Data.List"-        ,"import qualified Data.List.NonEmpty.Extra"+        ,"import qualified Data.Ord"         ,"import Test.QuickCheck.Instances.Semigroup ()"         ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))"         ,"tests :: IO ()"@@ -69,10 +73,20 @@     when (Just x /= old) $         writeFileBinary file x +exclude :: [String]+exclude =+    ["Data.Foldable.Extra" -- because all their imports clash+    ]++excludeTests :: [String]+-- FIXME: Should probably generate these in another module+excludeTests =+    ["Data.List.NonEmpty.Extra" -- because !? clashes and is tested+    ]+ hidden :: String -> [String]-hidden "Data.List.NonEmpty.Extra" = [ "cons", "snoc", "sortOn", "union", "unionBy"-                                    , "nubOrd", "nubOrdBy", "nubOrdOn"-                                    ]+hidden "Data.List.NonEmpty.Extra" = words+    "cons snoc sortOn union unionBy nubOrd nubOrdBy nubOrdOn (!?) foldl1' repeatedly compareLength" hidden _ = []  notHidden :: String -> String -> Bool

@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2014-2020.+Copyright Neil Mitchell 2014-2025. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -1,4 +1,4 @@-# Extra [![Hackage version](https://img.shields.io/hackage/v/extra.svg?label=Hackage)](https://hackage.haskell.org/package/extra) [![Stackage version](https://www.stackage.org/package/extra/badge/nightly?label=Stackage)](https://www.stackage.org/package/extra) [![Linux build status](https://img.shields.io/travis/ndmitchell/extra/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/extra) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/extra/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/extra)+# Extra [![Hackage version](https://img.shields.io/hackage/v/extra.svg?label=Hackage)](https://hackage.haskell.org/package/extra) [![Stackage version](https://www.stackage.org/package/extra/badge/nightly?label=Stackage)](https://www.stackage.org/package/extra) [![Build status](https://img.shields.io/github/actions/workflow/status/ndmitchell/extra/ci.yml?branch=master)](https://github.com/ndmitchell/extra/actions)  A library of extra functions for the standard Haskell libraries. Most functions are simple additions, filling out missing functionality. A few functions are available in later versions of GHC, but this package makes them available back to GHC 7.10. A few examples: @@ -15,9 +15,13 @@  * I have been using most of these functions in my packages - they have proved useful enough to be worth copying/pasting into each project. * The functions follow the spirit of the original Prelude/base libraries. I am happy to provide partial functions (e.g. `fromRight`), and functions which are specialisations of more generic functions (`whenJust`).-* Most of the functions have trivial implementations. If a beginner couldn't write the function, it probably doesn't belong here.+* Most of the functions have trivial implementations that are obvious from their name/signature. If a beginner couldn't write the function, it probably doesn't belong here. * I have defined only a few new data types or type aliases. It's a package for defining new utilities on existing types, not new types or concepts.  ## Base versions  A mapping between `base` versions and GHC compiler versions can be found [here](https://wiki.haskell.org/Base_package#Versions).++## Contributing++My general contribution preferences are [available here](https://github.com/ndmitchell/neil#contributions). In addition, this repo contains some generated code which is checked in, namely [src/Extra.hs](src/Extra.hs) and [test/TestGen.hs](test/TestGen.hs). You can generate those files by either running `runghc Generate.hs` or `ghci` (which uses the [`.ghci` file](.ghci)) and typing `:generate`. All PR's should contain regenerated versions of those files.

@@ -1,13 +1,13 @@-cabal-version:      >= 1.18+cabal-version:      1.18 build-type:         Simple name:               extra-version:            1.6.21+version:            1.8.1 license:            BSD3 license-file:       LICENSE category:           Development author:             Neil Mitchell <ndmitchell@gmail.com> maintainer:         Neil Mitchell <ndmitchell@gmail.com>-copyright:          Neil Mitchell 2014-2020+copyright:          Neil Mitchell 2014-2025 synopsis:           Extra functions I use. description:     A library of extra functions for the standard Haskell libraries. Most functions are simple additions, filling out missing functionality. A few functions are available in later versions of GHC, but this package makes them available back to GHC 7.2.@@ -15,7 +15,7 @@     The module "Extra" documents all functions provided by this library. Modules such as "Data.List.Extra" provide extra functions over "Data.List" and also reexport "Data.List". Users are recommended to replace "Data.List" imports with "Data.List.Extra" if they need the extra functionality. homepage:           https://github.com/ndmitchell/extra#readme bug-reports:        https://github.com/ndmitchell/extra/issues-tested-with:        GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3+tested-with:        GHC==9.12, GHC==9.10, GHC==9.8, GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8  extra-doc-files:     CHANGES.txt@@ -31,13 +31,11 @@     default-language: Haskell2010     hs-source-dirs: src     build-depends:-        base >= 4.8 && < 5,+        base >= 4.9 && < 5,         directory,         filepath,         process,         clock >= 0.7,-        -- For GHC 7.10 since Data.List.NonEmpty wasn't in base then-        semigroups,         time     if !os(windows)         build-depends: unix@@ -49,10 +47,12 @@         Control.Concurrent.Extra         Control.Exception.Extra         Control.Monad.Extra+        Data.Foldable.Extra         Data.Either.Extra         Data.IORef.Extra         Data.List.Extra         Data.List.NonEmpty.Extra+        Data.Monoid.Extra         Data.Tuple.Extra         Data.Typeable.Extra         Data.Version.Extra

@@ -4,13 +4,13 @@ -- --   This module includes three new types of 'MVar', namely 'Lock' (no associated value), --   'Var' (never empty) and 'Barrier' (filled at most once). See---   <httpd://neilmitchell.blogspot.co.uk/2012/06/flavours-of-mvar_04.html this blog post>+--   <https://neilmitchell.blogspot.co.uk/2012/06/flavours-of-mvar_04.html this blog post> --   for examples and justification. -- --   If you need greater control of exceptions and threads --   see the <https://hackage.haskell.org/package/slave-thread slave-thread> package. --   If you need elaborate relationships between threads---   see the <httdp://hackage.haskell.org/package/async async> package.+--   see the <https://hackage.haskell.org/package/async async> package. module Control.Concurrent.Extra(     module Control.Concurrent,     withNumCapabilities,@@ -18,7 +18,11 @@     -- * Lock     Lock, newLock, withLock, withLockTry,     -- * Var-    Var, newVar, readVar, writeVar, modifyVar, modifyVar_, withVar,+    Var, newVar, readVar,+    writeVar, writeVar',+    modifyVar, modifyVar',+    modifyVar_, modifyVar_',+    withVar,     -- * Barrier     Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,     ) where@@ -30,6 +34,7 @@ import Data.Either.Extra import Data.Functor import Prelude+import Data.Tuple.Extra (dupe)   -- | On GHC 7.6 and above with the @-threaded@ flag, brackets a call to 'setNumCapabilities'.@@ -88,7 +93,7 @@ -- -- @ -- lock <- 'newLock'--- let output = 'withLock' . putStrLn+-- let output = 'withLock' lock . putStrLn -- forkIO $ do ...; output \"hello\" -- forkIO $ do ...; output \"world\" -- @@@ -152,14 +157,34 @@ writeVar :: Var a -> a -> IO () writeVar v x = modifyVar_ v $ const $ pure x +-- | Strict variant of 'writeVar'+writeVar' :: Var a -> a -> IO ()+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 modifyVar (Var x) f = modifyMVar x f +-- | Strict variant of 'modifyVar''+modifyVar' :: Var a -> (a -> IO (a, b)) -> IO b+modifyVar' x f = do+    (newContents, res) <- modifyVar x $ \v -> do+        (newContents, res) <- f v+        pure (newContents, (newContents, res))+    evaluate newContents+    pure res+ -- | Modify a 'Var', a restricted version of 'modifyVar'. modifyVar_ :: Var a -> (a -> IO a) -> IO () modifyVar_ (Var x) f = modifyMVar_ x f +-- | Strict variant of 'modifyVar_'+modifyVar_' :: Var a -> (a -> IO a) -> IO ()+modifyVar_' x f = do+    newContents <- modifyVar x (fmap dupe . f)+    _ <- evaluate newContents+    pure ()+ -- | Perform some operation using the value in the 'Var', --   a restricted version of 'modifyVar'. withVar :: Var a -> (a -> IO b) -> IO b@@ -182,38 +207,26 @@ --   for it to complete. A barrier has similarities to a future or promise --   from other languages, has been known as an IVar in other Haskell work, --   and in some ways is like a manually managed thunk.-newtype Barrier a = Barrier (Var (Either (MVar ()) a))-    -- Either a Left empty MVar you should wait or a Right result-    -- With base 4.7 and above readMVar is atomic so you probably can implement Barrier directly on MVar a+newtype Barrier a = Barrier (MVar a)  -- | Create a new 'Barrier'. newBarrier :: IO (Barrier a)-newBarrier = fmap Barrier $ newVar . Left =<< newEmptyMVar+newBarrier = Barrier <$> newEmptyMVar  -- | Write a value into the Barrier, releasing anyone at 'waitBarrier'. --   Any subsequent attempts to signal the 'Barrier' will throw an exception. 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 -> pure (Right v, putMVar bar ())-        Right res -> error "Control.Concurrent.Extra.signalBarrier, attempt to signal a barrier that has already been signaled"+signalBarrier (Barrier var) v = do+    b <- tryPutMVar var v+    unless b $ errorIO "Control.Concurrent.Extra.signalBarrier, attempt to signal a barrier that has already been signaled"   -- | Wait until a barrier has been signaled with 'signalBarrier'. waitBarrier :: Barrier a -> IO a-waitBarrier (Barrier var) = do-    x <- readVar var-    case x of-        Right res -> pure res-        Left bar -> do-            readMVar bar-            x <- readVar var-            case x of-                Right res -> pure res-                Left bar -> error "Control.Concurrent.Extra, internal invariant violated in Barrier"+waitBarrier (Barrier var) = readMVar var   -- | A version of 'waitBarrier' that never blocks, returning 'Nothing' --   if the barrier has not yet been signaled. waitBarrierMaybe :: Barrier a -> IO (Maybe a)-waitBarrierMaybe (Barrier bar) = eitherToMaybe <$> readVar bar+waitBarrierMaybe (Barrier bar) = tryReadMVar bar

@@ -13,7 +13,7 @@     retry, retryBool,     errorWithoutStackTrace,     showException, stringException,-    errorIO,+    errorIO, assertIO,     -- * Exception catching/ignoring     ignore,     catch_, handle_, try_,@@ -76,6 +76,7 @@ -- -- > 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 @@ -84,6 +85,13 @@ withFrozenCallStack = id #endif +-- | An 'IO' action that when evaluated calls 'assert' in the 'IO' monad, which throws an 'AssertionFailed' exception if the argument is 'False'.+--   With optimizations enabled (and @-fgnore-asserts@) this function ignores its argument and does nothing.+--+-- > catch (assertIO True  >> pure 1) (\(x :: AssertionFailed) -> pure 2) == pure 1+-- > seq (assertIO False) (print 1) == print 1+assertIO :: Partial => Bool -> IO ()+assertIO x = withFrozenCallStack $ evaluate $ assert x ()  -- | 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.

@@ -7,11 +7,13 @@ module Control.Monad.Extra(     module Control.Monad,     whenJust, whenJustM,+    pureIf,     whenMaybe, whenMaybeM,     unit,     maybeM, fromMaybeM, eitherM,+    guarded, guardedA,     -- * Loops-    loop, loopM, whileM,+    loop, loopM, whileM, whileJustM, untilJustM,     -- * Lists     partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM,     fold1M, fold1M_,@@ -29,65 +31,104 @@ -- General utilities  -- | Perform some operation on 'Just', given the field inside the 'Just'.+--   This is a specialized 'Data.Foldable.for_'. -- -- > whenJust Nothing  print == pure () -- > whenJust (Just 1) print == print 1+{-# INLINABLE whenJust #-} whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust mg f = maybe (pure ()) f mg  -- | Like 'whenJust', but where the test can be monadic.+{-# INLINABLE whenJustM #-} 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 (pure ()) f mg +-- | Return either a `pure` value if a condition is `True`, otherwise `empty`.+--+-- > pureIf @Maybe True  5 == Just 5+-- > pureIf @Maybe False 5 == Nothing+-- > pureIf @[]    True  5 == [5]+-- > pureIf @[]    False 5 == []+{-# INLINABLE pureIf #-}+pureIf :: (Alternative m) => Bool -> a -> m a+pureIf b a = if b then pure a else empty  -- | Like 'when', but return either 'Nothing' if the predicate was 'False',---   of 'Just' with the result of the computation.+--   or 'Just' with the result of the computation. -- -- > whenMaybe True  (print 1) == fmap Just (print 1) -- > whenMaybe False (print 1) == pure Nothing+{-# INLINABLE whenMaybe #-} whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) whenMaybe b x = if b then Just <$> x else pure Nothing  -- | Like 'whenMaybe', but where the test can be monadic.+{-# INLINABLE whenMaybeM #-} whenMaybeM :: Monad m => m Bool -> m a -> m (Maybe a) -- 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 pure Nothing - -- | The identity function which requires the inner argument to be @()@. Useful for functions --   with overloaded return types. -- -- > \(x :: Maybe ()) -> unit x == x+{-# INLINABLE unit #-} unit :: m () -> m () unit = id   -- | Monadic generalisation of 'maybe'.+{-# INLINABLE maybeM #-} maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM n j x = maybe n j =<< x   -- | Monadic generalisation of 'fromMaybe'.+{-# INLINABLE fromMaybeM #-} fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a fromMaybeM n x = maybeM n pure x   -- | Monadic generalisation of 'either'.+{-# INLINABLE eitherM #-} eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c eitherM l r x = either l r =<< x +-- | Either lifts a value into an alternative context or gives a+--   minimal value depending on a predicate. Works with 'Alternative's.+--+-- > guarded even 2 == [2]+-- > guarded odd 2 == Nothing+-- > guarded (not.null) "My Name" == Just "My Name"+{-# INLINABLE guarded #-}+guarded :: Alternative m => (a -> Bool) -> a -> m a+guarded pred x = if pred x then pure x else empty++-- | A variant of `guarded` using 'Functor'-wrapped values.+--+-- > guardedA (return . even) 42    == Just [42]+-- > guardedA (return . odd) 42     == Just []+-- > guardedA (const Nothing) 42    == (Nothing :: Maybe [Int])+{-# INLINABLE guardedA #-}+guardedA :: (Functor f, Alternative m) => (a -> f Bool) -> a -> f (m a)+guardedA pred x = fmap inner (pred x)+    where inner b = if b then pure x else empty+ -- | A variant of 'foldM' that has no base case, and thus may only be applied to non-empty lists. -- -- > fold1M (\x y -> Just x) [] == undefined -- > fold1M (\x y -> Just $ x + y) [1, 2, 3] == Just 6+{-# INLINABLE fold1M #-} fold1M :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m a fold1M f (x:xs) = foldM f x xs fold1M f xs = error "fold1M: empty list"  -- | Like 'fold1M' but discards the result.+{-# INLINABLE fold1M_ #-} fold1M_ :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m () fold1M_ f xs = fold1M f xs >> pure () @@ -98,6 +139,7 @@ -- -- > partitionM (Just . even) [1,2,3] == Just ([2], [1,3]) -- > partitionM (const Nothing) [1,2,3] == Nothing+{-# INLINABLE partitionM #-} partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) partitionM f [] = pure ([], []) partitionM f (x:xs) = do@@ -114,10 +156,12 @@  -- | Like 'concatMapM', but has its arguments flipped, so can be used --   instead of the common @fmap concat $ forM@ pattern.+{-# INLINABLE concatForM #-} concatForM :: Monad m => [a] -> (a -> m [b]) -> m [b] concatForM = flip concatMapM  -- | A version of 'mconcatMap' that works with a monadic predicate.+{-# INLINABLE mconcatMapM #-} mconcatMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b mconcatMapM f = liftM mconcat . mapM f @@ -133,6 +177,7 @@ --   or 'Right' to abort the loop. -- -- > loop (\x -> if x < 10 then Left $ x * 2 else Right $ show x) 1 == "16"+{-# INLINABLE loop #-} loop :: (a -> Either a b) -> a -> b loop act x = case act x of     Left x -> loop act x@@ -140,6 +185,7 @@  -- | A monadic version of 'loop', where the predicate returns 'Left' as a seed for the next loop --   or 'Right' to abort the loop.+{-# INLINABLE loopM #-} loopM :: Monad m => (a -> m (Either a b)) -> a -> m b loopM act x = do     res <- act x@@ -155,26 +201,53 @@ -- @ -- --   If you need some state persisted between each test, use 'loopM'.+{-# INLINABLE whileM #-} whileM :: Monad m => m Bool -> m () whileM act = do     b <- act     when b $ whileM act +-- | Keep running an operation until it becomes a 'Nothing', accumulating the+--   monoid results inside the 'Just's as the result of the overall loop.+{-# INLINABLE whileJustM #-}+whileJustM :: (Monad m, Monoid a) => m (Maybe a) -> m a+whileJustM act = go mempty+  where+    go accum = do+        res <- act+        case res of+            Nothing -> pure accum+            Just r -> go $! (accum <> r) -- strict apply, otherwise space leaks++-- | Keep running an operation until it becomes a 'Just', then return the value+--   inside the 'Just' as the result of the overall loop.+{-# INLINABLE untilJustM #-}+untilJustM :: Monad m => m (Maybe a) -> m a+untilJustM act = do+    res <- act+    case res of+        Just r  -> pure r+        Nothing -> untilJustM act+ -- Booleans  -- | Like 'when', but where the test can be monadic.+{-# INLINABLE whenM #-} whenM :: Monad m => m Bool -> m () -> m () whenM b t = ifM b t (pure ())  -- | Like 'unless', but where the test can be monadic.+{-# INLINABLE unlessM #-} unlessM :: Monad m => m Bool -> m () -> m () unlessM b f = ifM b (pure ()) f  -- | Like @if@, but where the test can be monadic.+{-# INLINABLE ifM #-} ifM :: Monad m => m Bool -> m a -> m a -> m a ifM b t f = do b <- b; if b then t else f  -- | Like 'not', but where the test can be monadic.+{-# INLINABLE notM #-} notM :: Functor m => m Bool -> m Bool notM = fmap not @@ -185,6 +258,7 @@ -- > Just True  ||^ undefined  == Just True -- > Just False ||^ Just True  == Just True -- > Just False ||^ Just False == Just False+{-# INLINABLE (||^) #-} (||^) :: Monad m => m Bool -> m Bool -> m Bool (||^) a b = ifM a (pure True) b @@ -195,6 +269,7 @@ -- > Just False &&^ undefined  == Just False -- > Just True  &&^ Just True  == Just True -- > Just True  &&^ Just False == Just False+{-# INLINABLE (&&^) #-} (&&^) :: Monad m => m Bool -> m Bool -> m Bool (&&^) a b = ifM a b (pure False) @@ -203,6 +278,7 @@ -- > anyM Just [False,True ,undefined] == Just True -- > anyM Just [False,False,undefined] == undefined -- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)+{-# INLINABLE anyM #-} anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM p = foldr ((||^) . p) (pure False) @@ -211,6 +287,7 @@ -- > allM Just [True,False,undefined] == Just False -- > allM Just [True,True ,undefined] == undefined -- > \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)+{-# INLINABLE allM #-} allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM p = foldr ((&&^) . p) (pure True) @@ -219,6 +296,7 @@ -- > orM [Just False,Just True ,undefined] == Just True -- > orM [Just False,Just False,undefined] == undefined -- > \xs -> Just (or xs) == orM (map Just xs)+{-# INLINABLE orM #-} orM :: Monad m => [m Bool] -> m Bool orM = anyM id @@ -227,6 +305,7 @@ -- > andM [Just True,Just False,undefined] == Just False -- > andM [Just True,Just True ,undefined] == undefined -- > \xs -> Just (and xs) == andM (map Just xs)+{-# INLINABLE andM #-} andM :: Monad m => [m Bool] -> m Bool andM = allM id @@ -237,10 +316,12 @@ -- > findM (Just . isUpper) "teST"             == Just (Just 'S') -- > findM (Just . isUpper) "test"             == Just Nothing -- > findM (Just . const True) ["x",undefined] == Just (Just "x")+{-# INLINABLE findM #-} findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) 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.+{-# INLINABLE firstJustM #-} firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) firstJustM p [] = pure Nothing firstJustM p (x:xs) = maybeM (firstJustM p xs) (pure . Just) (p x)

@@ -0,0 +1,71 @@+module Data.Foldable.Extra+    ( module Data.Foldable+    , notNull+    , sum'+    , product'+    , sumOn'+    , productOn'+    , anyM+    , allM+    , orM+    , andM+    , findM+    , firstJustM+    , compareLength+    ) where++import Data.Foldable+import qualified Control.Monad.Extra as MX++-- | Composition of 'not' and 'null'+notNull :: Foldable f => f a -> Bool+notNull = not . null++-- | A generalization of 'Data.List.Extra.sum'' to 'Foldable' instances.+sum' :: (Foldable f, Num a) => f a -> a+sum' = foldl' (+) 0++-- | A generalization of 'Data.List.Extra.product'' to 'Foldable' instances.+product' :: (Foldable f, Num a) => f a -> a+product' = foldl' (*) 1++-- | A generalization of 'Data.List.Extra.sumOn'' to 'Foldable' instances.+sumOn' :: (Foldable f, Num b) => (a -> b) -> f a -> b+sumOn' f = foldl' (\acc x -> acc + f x) 0++-- | A generalization of 'Data.List.Extra.productOn'' to 'Foldable' instances.+productOn' :: (Foldable f, Num b) => (a -> b) -> f a -> b+productOn' f = foldl' (\acc x -> acc * f x) 1++-- | A generalization of 'Control.Monad.Extra.anyM' to 'Foldable' instances. Retains the short-circuiting behaviour.+anyM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool+anyM p = foldr ((MX.||^) . p) (pure False)++-- | A generalization of 'Control.Monad.Extra.allM' to 'Foldable' instances. Retains the short-circuiting behaviour.+allM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m Bool+allM p = foldr ((MX.&&^) . p) (pure True)++-- | A generalization of 'Control.Monad.Extra.orM' to 'Foldable' instances. Retains the short-circuiting behaviour.+orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool+orM = anyM id++-- | A generalization of 'Control.Monad.Extra.andM' to 'Foldable' instances. Retains the short-circuiting behaviour.+andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool+andM = allM id++-- | A generalization of 'Control.Monad.Extra.findM' to 'Foldable' instances.+findM :: (Foldable f, Monad m) => (a -> m Bool) -> f a -> m (Maybe a)+findM p = foldr (\x -> MX.ifM (p x) (pure $ Just x)) (pure Nothing)++-- | A generalization of 'Control.Monad.Extra.firstJustM' to 'Foldable' instances.+firstJustM :: (Foldable f, Monad m) => (a -> m (Maybe b)) -> f a -> m (Maybe b)+firstJustM p = MX.firstJustM p . toList++-- | Lazily compare the length of a 'Foldable' with a number.+--+-- > compareLength [1,2,3] 1 == GT+-- > compareLength [1,2] 2 == EQ+-- > \(xs :: [Int]) n -> compareLength xs n == compare (length xs) n+-- > compareLength (1:2:3:undefined) 2 == GT+compareLength :: Foldable f => f a -> Int -> Ordering+compareLength = foldr (\_ acc n -> if n > 0 then acc (n - 1) else GT) (compare 0)

@@ -1,4 +1,5 @@-{-# LANGUAGE TupleSections, BangPatterns, ConstraintKinds #-}+{-# LANGUAGE CPP, TupleSections, ConstraintKinds #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}  -- | This module extends "Data.List" with extra functions of a similar nature. --   The package also exports the existing "Data.List" functions.@@ -18,20 +19,22 @@     wordsBy, linesBy,     breakOn, breakOnEnd, splitOn, split, chunksOf,     -- * Basics-    headDef, lastDef, notNull, list, unsnoc, cons, snoc,-    drop1, dropEnd1, mconcatMap,+    headDef, lastDef, (!?), notNull, list, unsnoc, cons, snoc,+    drop1, dropEnd1, mconcatMap, compareLength, comparingLength,     -- * Enum operations     enumerate,     -- * List operations     groupSort, groupSortOn, groupSortBy,     nubOrd, nubOrdBy, nubOrdOn,-    nubOn, groupOn,+    nubOn, groupOn, groupOnKey,     nubSort, nubSortBy, nubSortOn,     maximumOn, minimumOn,-    disjoint, allSame, anySame,-    repeatedly, for, firstJust,+    sum', product',+    sumOn', productOn',+    disjoint, disjointOrd, disjointOrdBy, allSame, anySame,+    repeatedly, repeatedlyNE, firstJust,     concatUnzip, concatUnzip3,-    zipFrom, zipWithFrom,+    zipFrom, zipWithFrom, zipWithLongest,     replace, merge, mergeBy,     ) where @@ -44,12 +47,18 @@ import Data.Monoid import Numeric import Data.Functor+import Data.Foldable import Prelude+import Data.List.NonEmpty (NonEmpty ((:|)))   -- | Apply some operation repeatedly, producing an element of output --   and the remainder of the list. --+-- When the empty list is reached it is returned, so the operation+-- is /never/ applied to the empty input.+-- That fact is encoded in the type system with 'repeatedlyNE'+-- -- > \xs -> repeatedly (splitAt 3) xs  == chunksOf 3 xs -- > \xs -> repeatedly word1 (trim xs) == words xs -- > \xs -> repeatedly line1 xs == lines xs@@ -58,14 +67,17 @@ repeatedly f as = b : repeatedly f as'     where (b, as') = f as ---- | /DEPRECATED/ Use @flip map@ directly, since this function clashes with @Data.Traversable.for@.+-- | Apply some operation repeatedly, producing an element of output+--   and the remainder of the list. -----   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+-- Identical to 'repeatedly', but has a more precise type signature.+repeatedlyNE :: (NonEmpty a -> (b, [a])) -> [a] -> [b]+repeatedlyNE f [] = []+repeatedlyNE f (a : as) = b : repeatedlyNE f as'+    where (b, as') = f (a :| as) ++ -- | Are two lists disjoint, with no elements in common. -- -- > disjoint [1,2,3] [4,5] == True@@ -73,6 +85,33 @@ disjoint :: Eq a => [a] -> [a] -> Bool disjoint xs = null . intersect xs +-- | /O((m+n) log m), m <= n/. Are two lists disjoint, with no elements in common.+--+-- @disjointOrd@ is more strict than `disjoint`. For example, @disjointOrd@ cannot+-- terminate if both lists are infinite, while `disjoint` can.+--+-- > disjointOrd [1,2,3] [4,5] == True+-- > disjointOrd [1,2,3] [4,1] == False+disjointOrd :: Ord a => [a] -> [a] -> Bool+disjointOrd = disjointOrdBy compare++-- | A version of 'disjointOrd' with a custom predicate.+--+-- > disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,5] == True+-- > disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,8] == False+disjointOrdBy :: (a -> a -> Ordering) -> [a] -> [a] -> Bool+disjointOrdBy cmp xs ys+    | shorter xs ys = go xs ys+    | otherwise = go ys xs+  where+    shorter _ [] = False+    shorter [] _ = True+    shorter (_:xs) (_:ys) = shorter xs ys++    go xs = not . any (\a -> memberRB cmp a tree)+      where+        tree = foldl' (flip (insertRB cmp)) E xs+ -- | Is there any element which occurs more than once. -- -- > anySame [1,1,2] == True@@ -118,6 +157,21 @@ lastDef d xs = foldl (\_ x -> x) d xs -- I know this looks weird, but apparently this is the fastest way to do this: https://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.List.html#last {-# INLINE lastDef #-} +#if __GLASGOW_HASKELL__ <= 906+-- | A total variant of the list index function `(!!)`.+--+-- > [2,3,4] !? 1    == Just 3+-- > [2,3,4] !? (-1) == Nothing+-- > []      !? 0    == Nothing+(!?) :: [a] -> Int -> Maybe a+xs !? n+  | n < 0     = Nothing+             -- Definition adapted from GHC.List+  | otherwise = foldr (\x r k -> case k of+                                   0 -> Just x+                                   _ -> r (k-1)) (const Nothing) xs n+{-# INLINABLE (!?) #-}+#endif  -- | A composition of 'not' and 'null'. --@@ -136,6 +190,7 @@ list nil cons [] = nil list nil cons (x:xs) = cons x xs +#if __GLASGOW_HASKELL__ <= 906 -- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'. -- -- > unsnoc "test" == Just ("tes",'t')@@ -146,6 +201,7 @@ unsnoc [x] = Just ([], x) unsnoc (x:xs) = Just (x:a, b)     where Just (a,b) = unsnoc xs+#endif  -- | Append an element to the start of a list, an alias for '(:)'. --@@ -176,7 +232,9 @@ -- > \i xs -> takeEnd i xs `isSuffixOf` xs -- > \i xs -> length (takeEnd i xs) == min (max 0 i) (length xs) takeEnd :: Int -> [a] -> [a]-takeEnd i xs = f xs (drop i xs)+takeEnd i xs+    | i <= 0 = []+    | otherwise = f xs (drop i xs)     where f (x:xs) (y:ys) = f xs ys           f xs _ = xs @@ -189,7 +247,9 @@ -- > \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i) -- > \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..] dropEnd :: Int -> [a] -> [a]-dropEnd i xs = f xs (drop i xs)+dropEnd i xs+    | i <= 0 = xs+    | otherwise = f xs (drop i xs)     where f (x:xs) (y:ys) = x : f xs ys           f _ _ = [] @@ -202,36 +262,36 @@ -- > \i xs -> uncurry (++) (splitAt i xs) == xs -- > \i xs -> splitAtEnd i xs == (dropEnd i xs, takeEnd i xs) splitAtEnd :: Int -> [a] -> ([a], [a])-splitAtEnd i xs = f xs (drop i xs)+splitAtEnd i xs+    | i <= 0 = (xs, [])+    | otherwise = f xs (drop i xs)     where f (x:xs) (y:ys) = first (x:) $ f xs ys           f xs _ = ([], xs)   -- | 'zip' against an enumeration.---   Never truncates the output - raises an error if the enumeration runs out.+--   Truncates the output 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.+--   Truncates the output 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'. -- -- > concatUnzip [("a","AB"),("bc","C")] == ("abc","ABC") concatUnzip :: [([a], [b])] -> ([a], [b])-concatUnzip = (concat *** concat) . unzip+concatUnzip = (concat *** concat) . Prelude.unzip  -- | A merging of 'unzip3' and 'concat'. --@@ -371,12 +431,26 @@   -- | A version of 'group' where the equality is done on some extracted value.-groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+--+-- > groupOn abs [1,-1,2] == [[1,-1], [2]]+groupOn :: Eq k => (a -> k) -> [a] -> [[a]] 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 'groupOn' which pairs each group with its "key" - the+--   extracted value used for equality testing.+--+-- > groupOnKey abs [1,-1,2] == [(1, [1,-1]), (2, [2])]+groupOnKey :: Eq k => (a -> k) -> [a] -> [(k, [a])]+groupOnKey _ []     = []+groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no+    where+        fx = f x+        (yes, no) = span (\y -> fx == f y) xs++ -- | /DEPRECATED/ Use 'nubOrdOn', since this function is _O(n^2)_. -- --   A version of 'nub' where the equality is done on some extracted value.@@ -422,7 +496,8 @@ -- > \xs -> map fst (groupSort xs) == sort (nub (map fst xs)) -- > \xs -> concatMap snd (groupSort xs) == map snd (sortOn fst xs) groupSort :: Ord k => [(k, v)] -> [(k, [v])]-groupSort = map (\x -> (fst $ head x, map snd x)) . groupOn fst . sortOn fst+groupSort = map (\x -> (fst $ headErr x, map snd x)) . groupOn fst . sortOn fst+    where headErr (x:_) = x  -- | A combination of 'group' and 'sort', using a part of the value to compare on. --@@ -437,6 +512,32 @@ groupSortBy f = groupBy (\a b -> f a b == EQ) . sortBy f  +-- | A strict version of 'sum'.+--   Unlike 'sum' this function is always strict in the `Num` argument,+--   whereas the standard version is only strict if the optimiser kicks in.+--+-- > sum' [1, 2, 3] == 6+sum' :: (Num a) => [a] -> a+sum' = foldl' (+) 0++-- | A strict version of 'sum', using a custom valuation function.+--+-- > sumOn' read ["1", "2", "3"] == 6+sumOn' :: (Num b) => (a -> b) -> [a] -> b+sumOn' f = foldl' (\acc x -> acc + f x) 0++-- | A strict version of 'product'.+--+-- > product' [1, 2, 4] == 8+product' :: (Num a) => [a] -> a+product' = foldl' (*) 1++-- | A strict version of 'product', using a custom valuation function.+--+-- > productOn' read ["1", "2", "4"] == 8+productOn' :: (Num b) => (a -> b) -> [a] -> b+productOn' f = foldl' (\acc x -> acc * f x) 1+ -- | Merge two lists which are assumed to be ordered. -- -- > merge "ace" "bd" == "abcde"@@ -454,15 +555,17 @@     | otherwise = y : mergeBy f (x:xs) ys  --- | Replace a subsequence everywhere it occurs. The first argument must---   not be the empty list.+-- | Replace a subsequence everywhere it occurs. -- -- > replace "el" "_" "Hello Bella" == "H_lo B_la" -- > replace "el" "e" "Hello"       == "Helo"--- > replace "" "e" "Hello"         == undefined--- > \xs ys -> not (null xs) ==> replace xs xs ys == ys-replace :: (Partial, Eq a) => [a] -> [a] -> [a] -> [a]-replace [] _ _ = error "Extra.replace, first argument cannot be empty"+-- > replace "" "x" "Hello"         == "xHxexlxlxox"+-- > replace "" "x" ""              == "x"+-- > \xs ys -> replace xs xs ys == ys+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace [] to xs = go xs+    where go [] = to+          go (x:xs) = to ++ x : go xs replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs replace from to (x:xs) = x : replace from to xs replace from to [] = []@@ -713,6 +816,7 @@           f (x:xs) = x : f xs           f [] = [] +#if __GLASGOW_HASKELL__ <= 914 -- | /O(n log n)/. The 'nubOrd' function removes duplicate elements from a list. -- In particular, it keeps only the first occurrence of each element. -- Unlike the standard 'nub' operator, this version requires an 'Ord' instance@@ -723,6 +827,7 @@ -- > \xs -> nubOrd xs == nub xs nubOrd :: Ord a => [a] -> [a] nubOrd = nubOrdBy compare+#endif  -- | A version of 'nubOrd' which operates on a portion of the value. --@@ -730,6 +835,7 @@ nubOrdOn :: Ord b => (a -> b) -> [a] -> [a] nubOrdOn f = map snd . nubOrdBy (compare `on` fst) . map (f &&& id) +#if __GLASGOW_HASKELL__ <= 914 -- | A version of 'nubOrd' with a custom predicate. -- -- > nubOrdBy (compare `on` length) ["a","test","of","this"] == ["a","test","of"]@@ -738,43 +844,114 @@     where f seen [] = []           f seen (x:xs) | memberRB cmp x seen = f seen xs                         | otherwise = x : f (insertRB cmp x seen) xs+#endif  --------------------------------------------------------------------- -- OKASAKI RED BLACK TREE -- Taken from https://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs+-- But with the Color = R|B fused into the tree -data Color = R | B deriving Show-data RB a = E | T Color (RB a) a (RB a) deriving Show+data RB a = E | T_R (RB a) a (RB a) | T_B (RB a) a (RB a) deriving Show  {- Insertion and membership test as by Okasaki -} insertRB :: (a -> a -> Ordering) -> a -> RB a -> RB a-insertRB cmp x s =-    T B a z b+insertRB cmp x s = case ins s of+    T_R a z b -> T_B a z b+    x -> x     where-    T _ a z b = ins s-    ins E = T R E x E-    ins s@(T B a y b) = case cmp x y of-        LT -> balance (ins a) y b-        GT -> balance a y (ins b)+    ins E = T_R E x E+    ins s@(T_B a y b) = case cmp x y of+        LT -> lbalance (ins a) y b+        GT -> rbalance a y (ins b)         EQ -> s-    ins s@(T R a y b) = case cmp x y of-        LT -> T R (ins a) y b-        GT -> T R a y (ins b)+    ins s@(T_R a y b) = case cmp x y of+        LT -> T_R (ins a) y b+        GT -> T_R a y (ins b)         EQ -> s  memberRB :: (a -> a -> Ordering) -> a -> RB a -> Bool memberRB cmp x E = False-memberRB cmp x (T _ a y b) = case cmp x y of+memberRB cmp x (T_R a y b) = case cmp x y of     LT -> memberRB cmp x a     GT -> memberRB cmp x b     EQ -> True+memberRB cmp x (T_B a y b) = case cmp x y of+    LT -> memberRB cmp x a+    GT -> memberRB cmp x b+    EQ -> True  {- balance: first equation is new,    to make it work with a weaker invariant -}-balance :: RB a -> a -> RB a -> RB a-balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d)-balance (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)-balance (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)-balance a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)-balance a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)-balance a x b = T B a x b+lbalance, rbalance :: RB a -> a -> RB a -> RB a+lbalance (T_R a x b) y (T_R c z d) = T_R (T_B a x b) y (T_B c z d)+lbalance (T_R (T_R a x b) y c) z d = T_R (T_B a x b) y (T_B c z d)+lbalance (T_R a x (T_R b y c)) z d = T_R (T_B a x b) y (T_B c z d)+lbalance a x b = T_B a x b+rbalance (T_R a x b) y (T_R c z d) = T_R (T_B a x b) y (T_B c z d)+rbalance a x (T_R b y (T_R c z d)) = T_R (T_B a x b) y (T_B c z d)+rbalance a x (T_R (T_R b y c) z d) = T_R (T_B a x b) y (T_B c z d)+rbalance a x b = T_B a x b+++-- | Like 'zipWith', but keep going to the longest value. The function+--   argument will always be given at least one 'Just', and while both+--   lists have items, two 'Just' values.+--+-- > zipWithLongest (,) "a" "xyz" == [(Just 'a', Just 'x'), (Nothing, Just 'y'), (Nothing, Just 'z')]+-- > zipWithLongest (,) "a" "x" == [(Just 'a', Just 'x')]+-- > zipWithLongest (,) "" "x" == [(Nothing, Just 'x')]+zipWithLongest :: (Maybe a -> Maybe b -> c) -> [a] -> [b] -> [c]+zipWithLongest f [] [] = []+zipWithLongest f (x:xs) (y:ys) = f (Just x) (Just y) : zipWithLongest f xs ys+zipWithLongest f [] ys = map (f Nothing . Just) ys+zipWithLongest f xs [] = map ((`f` Nothing) . Just) xs++#if __GLASGOW_HASKELL__ <= 910+-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative+-- to 'compare' ('length' @xs@) @n@. Similarly, it's better+-- to write @compareLength xs 10 == LT@ instead of @length xs < 10@.+--+-- While 'length' would force and traverse+-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite),+-- 'compareLength' traverses at most @n@ elements to determine its result.+--+-- >>> compareLength [] 0+-- EQ+-- >>> compareLength [] 1+-- LT+-- >>> compareLength ['a'] 1+-- EQ+-- >>> compareLength ['a', 'b'] 1+-- GT+-- >>> compareLength [0..] 100+-- GT+-- >>> compareLength undefined (-1)+-- GT+-- >>> compareLength ('a' : undefined) 0+-- GT+--+-- @since 4.21.0.0+--+compareLength :: [a] -> Int -> Ordering+compareLength xs n+  | n < 0 = GT+  | otherwise = foldr+    (\_ f m -> if m > 0 then f (m - 1) else GT)+    (\m -> if m > 0 then LT else EQ)+    xs+    n+#endif++-- | Lazily compare the length of two 'Foldable's.+-- > comparingLength [1,2,3] [False] == GT+-- > comparingLength [1,2] "ab" == EQ+-- > \(xs :: [Int]) (ys :: [Int]) -> comparingLength xs ys == Data.Ord.comparing length xs ys+-- > comparingLength [1,2] (1:2:3:undefined) == LT+-- > comparingLength (1:2:3:undefined) [1,2] == GT+comparingLength :: (Foldable f1, Foldable f2) => f1 a -> f2 b -> Ordering+comparingLength x y = go (toList x) (toList y)+  where+    go [] [] = EQ+    go [] (_:_) = LT+    go (_:_) [] = GT+    go (_:xs) (_:ys) = go xs ys

@@ -1,14 +1,17 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}  -- | Extra functions for working with 'NonEmpty' lists. The package --   also exports the existing "Data.List.NonEmpty" functions. module Data.List.NonEmpty.Extra(     module Data.List.NonEmpty,-    (|:), (|>), snoc,+    (|:), (|>), snoc, (!?),     appendl, appendr,     sortOn, union, unionBy,     nubOrd, nubOrdBy, nubOrdOn,-    maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1+    maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1,+    foldl1', repeatedly,+    compareLength     ) where  import           Data.Function@@ -37,6 +40,18 @@ (|:) :: [a] -> a -> NonEmpty a (|:) xs x = foldr cons (pure x) xs +-- | A total variant of the list index function `(!?)`.+--+-- > (2 :| [3,4]) !? 1    == Just 3+-- > (2 :| [3,4]) !? (-1) == Nothing+-- > (1 :| [])    !? 1    == Nothing+(!?) :: NonEmpty a -> Int -> Maybe a+(!?) ~(x :| xs) n+  | n == 0 = Just x+  | n > 0  = xs List.!? (n - 1)+  | otherwise = Nothing+infixl 9 !?+ -- | Append a list to a non-empty list. -- -- > appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5]@@ -49,11 +64,13 @@ appendr :: [a] -> NonEmpty a -> NonEmpty a appendr l nel = foldr cons nel l +#if __GLASGOW_HASKELL__ <= 908 -- | Sort by comparing the results of a function applied to each element. --   The sort is stable, and the function is evaluated only once for --   each element. sortOn :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a sortOn f = fromList . List.sortOn f . toList+#endif  -- | Return the union of two non-empty lists. Duplicates, and elements of the --   first list, are removed from the the second list, but if the first list@@ -63,18 +80,22 @@ union :: Eq a => NonEmpty a -> NonEmpty a -> NonEmpty a union = unionBy (==) +#if __GLASGOW_HASKELL__ <= 914 -- | @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+#endif +#if __GLASGOW_HASKELL__ <= 914 -- | @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+#endif  -- | @nubOrdOn@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrdOn'. --@@ -111,3 +132,45 @@ -- | A version of 'minimum1' where the comparison is done on some extracted value. minimumOn1 :: Ord b => (a -> b) -> NonEmpty a -> a minimumOn1 f = minimumBy1 (compare `on` f)++-- | A strict variant of variant `foldl1`+foldl1' :: (a -> a -> a) -> NonEmpty a -> a+foldl1' f (x:|xs) =  List.foldl' f x xs++-- | Apply some operation repeatedly, producing an element of output+--   and the remainder of the list.+repeatedly :: (NonEmpty a -> (b, [a])) -> NonEmpty a -> NonEmpty b+repeatedly f (a :| as) = b :| List.repeatedlyNE f as'+    where (b, as') = f (a :| as)++#if __GLASGOW_HASKELL__ <= 910+-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative+-- to 'compare' ('length' @xs@) @n@. Similarly, it's better+-- to write @compareLength xs 10 == LT@ instead of @length xs < 10@.+--+-- While 'length' would force and traverse+-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite),+-- 'compareLength' traverses at most @n@ elements to determine its result.+--+-- >>> compareLength ('a' :| []) 1+-- EQ+-- >>> compareLength ('a' :| ['b']) 3+-- LT+-- >>> compareLength (0 :| [1..]) 100+-- GT+-- >>> compareLength undefined 0+-- GT+-- >>> compareLength ('a' :| 'b' : undefined) 1+-- GT+--+-- @since 4.21.0.0+--+compareLength :: NonEmpty a -> Int -> Ordering+compareLength xs n+  | n < 1 = GT+  | otherwise = foldr+    (\_ f m -> if m > 0 then f (m - 1) else GT)+    (\m -> if m > 0 then LT else EQ)+    xs+    n+#endif

@@ -0,0 +1,17 @@++-- | Extra functions for working with monoids.+module Data.Monoid.Extra(+    module Data.Monoid,+    -- * Extra operations+    mwhen+    ) where++import Data.Monoid++-- | Like 'Control.Monad.when', but operating on a 'Monoid'. If the first argument+--   is 'True' returns the second, otherwise returns 'mempty'.+--+-- > mwhen True  "test" == "test"+-- > mwhen False "test" == ""+mwhen :: Monoid a => Bool -> a -> a+mwhen b x = if b then x else mempty

@@ -13,6 +13,7 @@     firstM, secondM,     -- * Operations on triple     fst3, snd3, thd3,+    first3, second3, third3,     curry3, uncurry3     ) where @@ -37,13 +38,13 @@ -- -- > firstM (\x -> [x-1, x+1]) (1,"test") == [(0,"test"),(2,"test")] firstM :: Functor m => (a -> m a') -> (a, b) -> m (a', b)-firstM f (a,b) = (,b) <$> f a+firstM f ~(a,b) = (,b) <$> f a  -- | Update the second component of a pair. -- -- > secondM (\x -> [reverse x, x]) (1,"test") == [(1,"tset"),(1,"test")] secondM :: Functor m => (b -> m b') -> (a, b) -> m (a, b')-secondM f (a,b) = (a,) <$> f b+secondM f ~(a,b) = (a,) <$> f b  -- | Given two functions, apply one to the first component and one to the second. --   A specialised version of 'Control.Arrow.***'.@@ -69,7 +70,7 @@ -- -- > both succ (1,2) == (2,3) both :: (a -> b) -> (a, a) -> (b, b)-both f (x,y) = (f x, f y)+both f ~(x,y) = (f x, f y)  -- | Extract the 'fst' of a triple. fst3 :: (a,b,c) -> a@@ -90,3 +91,22 @@ -- | Converts a curried function to a function on a triple. uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d) uncurry3 f ~(a,b,c) = f a b c+++-- | Update the first component of a triple.+--+-- > first3 succ (1,1,1) == (2,1,1)+first3 :: (a -> a') -> (a, b, c) -> (a', b, c)+first3 f ~(a,b,c) = (f a,b,c)++-- | Update the second component of a triple.+--+-- > second3 succ (1,1,1) == (1,2,1)+second3 :: (b -> b') -> (a, b, c) -> (a, b', c)+second3 f ~(a,b,c) = (a,f b,c)++-- | Update the third component of a triple.+--+-- > third3 succ (1,1,1) == (1,1,2)+third3 :: (c -> c') -> (a, b, c) -> (a, b, c')+third3 f ~(a,b,c) = (a,b,f c)

@@ -3,7 +3,7 @@ --   The package also exports the existing "Data.Typeable" functions. -- --   Currently this module has no functionality beyond "Data.Typeable".-module Data.Typeable.Extra(+module Data.Typeable.Extra {-# DEPRECATED "Use Data.Typeable directly" #-} (     module Data.Typeable     ) where 

@@ -8,13 +8,13 @@ module Extra {-# DEPRECATED "This module is provided as documentation of all new functions, you should import the more specific modules directly." #-} (     -- * Control.Concurrent.Extra     -- | Extra functions available in @"Control.Concurrent.Extra"@.-    withNumCapabilities, once, onceFork, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, writeVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,+    withNumCapabilities, once, onceFork, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, writeVar, writeVar', modifyVar, modifyVar', modifyVar_, modifyVar_', withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,     -- * Control.Exception.Extra     -- | Extra functions available in @"Control.Exception.Extra"@.-    Partial, retry, retryBool, errorWithoutStackTrace, showException, stringException, errorIO, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool,+    Partial, retry, retryBool, errorWithoutStackTrace, showException, stringException, errorIO, assertIO, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool,     -- * Control.Monad.Extra     -- | Extra functions available in @"Control.Monad.Extra"@.-    whenJust, whenJustM, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, loop, loopM, whileM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, fold1M, fold1M_, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM,+    whenJust, whenJustM, pureIf, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, guarded, guardedA, loop, loopM, whileM, whileJustM, untilJustM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, fold1M, fold1M_, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM,     -- * Data.Either.Extra     -- | Extra functions available in @"Data.Either.Extra"@.     fromLeft, fromRight, fromEither, fromLeft', fromRight', eitherToMaybe, maybeToEither, mapLeft, mapRight,@@ -23,13 +23,16 @@     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, compareLength, comparingLength, enumerate, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, groupOnKey, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, sum', product', sumOn', productOn', disjoint, disjointOrd, disjointOrdBy, allSame, anySame, repeatedly, repeatedlyNE, firstJust, concatUnzip, concatUnzip3, zipFrom, zipWithFrom, zipWithLongest, replace, merge, mergeBy,     -- * Data.List.NonEmpty.Extra     -- | Extra functions available in @"Data.List.NonEmpty.Extra"@.     (|:), (|>), appendl, appendr, maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1,+    -- * Data.Monoid.Extra+    -- | Extra functions available in @"Data.Monoid.Extra"@.+    mwhen,     -- * Data.Tuple.Extra     -- | Extra functions available in @"Data.Tuple.Extra"@.-    first, second, (***), (&&&), dupe, both, firstM, secondM, fst3, snd3, thd3, curry3, uncurry3,+    first, second, (***), (&&&), dupe, both, firstM, secondM, fst3, snd3, thd3, first3, second3, third3, curry3, uncurry3,     -- * Data.Version.Extra     -- | Extra functions available in @"Data.Version.Extra"@.     readVersion,@@ -59,7 +62,8 @@ import Data.Either.Extra import Data.IORef.Extra import Data.List.Extra-import Data.List.NonEmpty.Extra hiding (cons, snoc, sortOn, union, unionBy, nubOrd, nubOrdBy, nubOrdOn)+import Data.List.NonEmpty.Extra hiding (cons, snoc, sortOn, union, unionBy, nubOrd, nubOrdBy, nubOrdOn, (!?), foldl1', repeatedly, compareLength)+import Data.Monoid.Extra import Data.Tuple.Extra import Data.Version.Extra import Numeric.Extra

@@ -1,9 +1,8 @@ --- | 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.+-- | Extra functions for "System.Environment". -- --   Currently this module has no functionality beyond "System.Environment".-module System.Environment.Extra(+module System.Environment.Extra  {-# DEPRECATED "Use System.Environment directly" #-} (     module System.Environment,     ) where 

@@ -1,4 +1,5 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, CPP #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}  -- | 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@@ -61,6 +62,9 @@  -- Strict file reading +#if __GLASGOW_HASKELL__ < 811+-- readFile' and hGetContents' were added in GHC 9.0+ -- | A strict version of 'hGetContents'. hGetContents' :: Handle -> IO String hGetContents' h = do@@ -75,6 +79,8 @@ -- > \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file readFile' :: FilePath -> IO String readFile' file = withFile file ReadMode hGetContents'++#endif  -- | A strict version of 'readFileEncoding', see 'readFile'' for details. readFileEncoding' :: TextEncoding -> FilePath -> IO String

@@ -15,6 +15,7 @@ import Control.Concurrent import System.Clock import Numeric.Extra+import Control.Monad.IO.Class import Control.Monad.Extra import Control.Exception.Extra import Data.Typeable@@ -108,9 +109,9 @@ -- | Record how long a computation takes in 'Seconds'. -- -- > do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5-duration :: IO a -> IO (Seconds, a)+duration :: MonadIO m => m a -> m (Seconds, a) duration act = do-    time <- offsetTime+    time <- liftIO offsetTime     res <- act-    time <- time+    time <- liftIO time     pure (time, res)

@@ -2,7 +2,7 @@ -- | This module provides "Text.Read" with functions added in later versions. -- --   Currently this module has no functionality beyond "Text.Read".-module Text.Read.Extra(+module Text.Read.Extra {-# DEPRECATED "Use Text.Read directly" #-} (     module Text.Read,     ) where 

@@ -16,5 +16,6 @@  main :: IO () main = runTests $ do+    testSetup     tests     testCustom

@@ -1,18 +1,26 @@ -module TestCustom(testCustom) where+module TestCustom(testSetup, testCustom) where  import Control.Concurrent.Extra import Control.Monad import System.IO.Extra import Data.IORef import TestUtil-import Data.Typeable.Extra as X+import Data.List.Extra as X  +-- | Test that the basic test mechanisms work+testSetup :: IO ()+testSetup = do+    testGen "withTempFile" $ withTempFile (`writeFile` "") == pure ()+    testGen "captureOutput" $ captureOutput (print 1) == pure ("1\n", ())+++-- | Custom written tests testCustom :: IO () testCustom = do     -- check that Extra really does export these things-    testGen "Extra export" $ Proxy == (X.Proxy :: Proxy ())+    testGen "Extra export" $ X.sort [1] == [1]      testRaw "withTempFile" $ do         xs <- replicateM 4 $ onceFork $ do@@ -32,3 +40,12 @@         ref <- newIORef 2         retry 5 $ do modifyIORef ref pred; whenM ((/=) 0 <$> readIORef ref) $ fail "die"         (==== 0) <$> readIORef ref++    testRaw "barrier" $ do+        bar <- newBarrier+        (==== Nothing) <$> waitBarrierMaybe bar+        signalBarrier bar 1+        (==== Just 1) <$> waitBarrierMaybe bar+        (==== 1) <$> waitBarrier bar+        Left _ <- try_ $ signalBarrier bar 2+        pure ()

@@ -1,11 +1,11 @@ -- GENERATED CODE - DO NOT MODIFY -- See Generate.hs for details of how to generate -{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-}+{-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, TypeApplications, ViewPatterns #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-} module TestGen(tests) where import TestUtil-import qualified Data.List-import qualified Data.List.NonEmpty.Extra+import qualified Data.Ord import Test.QuickCheck.Instances.Semigroup () default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO ()@@ -25,13 +25,25 @@     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 "catch (assertIO True  >> pure 1) (\\(x :: AssertionFailed) -> pure 2) == pure 1" $ catch (assertIO True  >> pure 1) (\(x :: AssertionFailed) -> pure 2) == pure 1+    testGen "seq (assertIO False) (print 1) == print 1" $ seq (assertIO False) (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 == pure ()" $ whenJust Nothing  print == pure ()     testGen "whenJust (Just 1) print == print 1" $ whenJust (Just 1) print == print 1+    testGen "pureIf @Maybe True  5 == Just 5" $ pureIf @Maybe True  5 == Just 5+    testGen "pureIf @Maybe False 5 == Nothing" $ pureIf @Maybe False 5 == Nothing+    testGen "pureIf @[]    True  5 == [5]" $ pureIf @[]    True  5 == [5]+    testGen "pureIf @[]    False 5 == []" $ pureIf @[]    False 5 == []     testGen "whenMaybe True  (print 1) == fmap Just (print 1)" $ whenMaybe True  (print 1) == fmap Just (print 1)     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 "guarded even 2 == [2]" $ guarded even 2 == [2]+    testGen "guarded odd 2 == Nothing" $ guarded odd 2 == Nothing+    testGen "guarded (not.null) \"My Name\" == Just \"My Name\"" $ guarded (not.null) "My Name" == Just "My Name"+    testGen "guardedA (return . even) 42    == Just [42]" $ guardedA (return . even) 42    == Just [42]+    testGen "guardedA (return . odd) 42     == Just []" $ guardedA (return . odd) 42     == Just []+    testGen "guardedA (const Nothing) 42    == (Nothing :: Maybe [Int])" $ guardedA (const Nothing) 42    == (Nothing :: Maybe [Int])     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     testGen "partitionM (Just . even) [1,2,3] == Just ([2], [1,3])" $ partitionM (Just . even) [1,2,3] == Just ([2], [1,3])@@ -81,6 +93,10 @@     testGen "\\xs -> repeatedly line1 xs == lines xs" $ \xs -> repeatedly line1 xs == lines xs     testGen "disjoint [1,2,3] [4,5] == True" $ disjoint [1,2,3] [4,5] == True     testGen "disjoint [1,2,3] [4,1] == False" $ disjoint [1,2,3] [4,1] == False+    testGen "disjointOrd [1,2,3] [4,5] == True" $ disjointOrd [1,2,3] [4,5] == True+    testGen "disjointOrd [1,2,3] [4,1] == False" $ disjointOrd [1,2,3] [4,1] == False+    testGen "disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,5] == True" $ disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,5] == True+    testGen "disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,8] == False" $ disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,8] == False     testGen "anySame [1,1,2] == True" $ anySame [1,1,2] == True     testGen "anySame [1,2,3] == False" $ anySame [1,2,3] == False     testGen "anySame (1:2:1:undefined) == True" $ anySame (1:2:1:undefined) == True@@ -98,6 +114,9 @@     testGen "lastDef 1 []      == 1" $ lastDef 1 []      == 1     testGen "lastDef 1 [2,3,4] == 4" $ lastDef 1 [2,3,4] == 4     testGen "\\x xs -> lastDef x xs == last (x:xs)" $ \x xs -> lastDef x xs == last (x:xs)+    testGen "[2,3,4] !? 1    == Just 3" $ [2,3,4] !? 1    == Just 3+    testGen "[2,3,4] !? (-1) == Nothing" $ [2,3,4] !? (-1) == Nothing+    testGen "[]      !? 0    == Nothing" $ []      !? 0    == Nothing     testGen "notNull []  == False" $ notNull []  == False     testGen "notNull [1] == True" $ notNull [1] == True     testGen "\\xs -> notNull xs == not (null xs)" $ \xs -> notNull xs == not (null xs)@@ -128,7 +147,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")@@ -159,6 +178,8 @@     testGen "escapeJSON \"\\ttab\\nnewline\\\\\" == \"\\\\ttab\\\\nnewline\\\\\\\\\"" $ escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\"     testGen "escapeJSON \"\\ESC[0mHello\" == \"\\\\u001b[0mHello\"" $ escapeJSON "\ESC[0mHello" == "\\u001b[0mHello"     testGen "\\xs -> unescapeJSON (escapeJSON xs) == xs" $ \xs -> unescapeJSON (escapeJSON xs) == xs+    testGen "groupOn abs [1,-1,2] == [[1,-1], [2]]" $ groupOn abs [1,-1,2] == [[1,-1], [2]]+    testGen "groupOnKey abs [1,-1,2] == [(1, [1,-1]), (2, [2])]" $ groupOnKey abs [1,-1,2] == [(1, [1,-1]), (2, [2])]     testGen "maximumOn id [] == undefined" $ erroneous $ maximumOn id []     testGen "maximumOn length [\"test\",\"extra\",\"a\"] == \"extra\"" $ maximumOn length ["test","extra","a"] == "extra"     testGen "minimumOn id [] == undefined" $ erroneous $ minimumOn id []@@ -168,12 +189,17 @@     testGen "\\xs -> concatMap snd (groupSort xs) == map snd (sortOn fst xs)" $ \xs -> concatMap snd (groupSort xs) == map snd (sortOn fst xs)     testGen "groupSortOn length [\"test\",\"of\",\"sized\",\"item\"] == [[\"of\"],[\"test\",\"item\"],[\"sized\"]]" $ groupSortOn length ["test","of","sized","item"] == [["of"],["test","item"],["sized"]]     testGen "groupSortBy (compare `on` length) [\"test\",\"of\",\"sized\",\"item\"] == [[\"of\"],[\"test\",\"item\"],[\"sized\"]]" $ groupSortBy (compare `on` length) ["test","of","sized","item"] == [["of"],["test","item"],["sized"]]+    testGen "sum' [1, 2, 3] == 6" $ sum' [1, 2, 3] == 6+    testGen "sumOn' read [\"1\", \"2\", \"3\"] == 6" $ sumOn' read ["1", "2", "3"] == 6+    testGen "product' [1, 2, 4] == 8" $ product' [1, 2, 4] == 8+    testGen "productOn' read [\"1\", \"2\", \"4\"] == 8" $ productOn' read ["1", "2", "4"] == 8     testGen "merge \"ace\" \"bd\" == \"abcde\"" $ merge "ace" "bd" == "abcde"     testGen "\\xs ys -> merge (sort xs) (sort ys) == sort (xs ++ ys)" $ \xs ys -> merge (sort xs) (sort ys) == sort (xs ++ ys)     testGen "replace \"el\" \"_\" \"Hello Bella\" == \"H_lo B_la\"" $ replace "el" "_" "Hello Bella" == "H_lo B_la"     testGen "replace \"el\" \"e\" \"Hello\"       == \"Helo\"" $ replace "el" "e" "Hello"       == "Helo"-    testGen "replace \"\" \"e\" \"Hello\"         == undefined" $ erroneous $ replace "" "e" "Hello"-    testGen "\\xs ys -> not (null xs) ==> replace xs xs ys == ys" $ \xs ys -> not (null xs) ==> replace xs xs ys == ys+    testGen "replace \"\" \"x\" \"Hello\"         == \"xHxexlxlxox\"" $ replace "" "x" "Hello"         == "xHxexlxlxox"+    testGen "replace \"\" \"x\" \"\"              == \"x\"" $ replace "" "x" ""              == "x"+    testGen "\\xs ys -> replace xs xs ys == ys" $ \xs ys -> replace xs xs ys == ys     testGen "breakEnd isLower \"youRE\" == (\"you\",\"RE\")" $ breakEnd isLower "youRE" == ("you","RE")     testGen "breakEnd isLower \"youre\" == (\"youre\",\"\")" $ breakEnd isLower "youre" == ("youre","")     testGen "breakEnd isLower \"YOURE\" == (\"\",\"YOURE\")" $ breakEnd isLower "YOURE" == ("","YOURE")@@ -241,15 +267,16 @@     testGen "\\xs -> nubOrd xs == nub xs" $ \xs -> nubOrd xs == nub xs     testGen "nubOrdOn length [\"a\",\"test\",\"of\",\"this\"] == [\"a\",\"test\",\"of\"]" $ nubOrdOn length ["a","test","of","this"] == ["a","test","of"]     testGen "nubOrdBy (compare `on` length) [\"a\",\"test\",\"of\",\"this\"] == [\"a\",\"test\",\"of\"]" $ nubOrdBy (compare `on` length) ["a","test","of","this"] == ["a","test","of"]-    testGen "(1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5]" $ (1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5]-    testGen "[1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5]" $ [1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5]-    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 "zipWithLongest (,) \"a\" \"xyz\" == [(Just 'a', Just 'x'), (Nothing, Just 'y'), (Nothing, Just 'z')]" $ zipWithLongest (,) "a" "xyz" == [(Just 'a', Just 'x'), (Nothing, Just 'y'), (Nothing, Just 'z')]+    testGen "zipWithLongest (,) \"a\" \"x\" == [(Just 'a', Just 'x')]" $ zipWithLongest (,) "a" "x" == [(Just 'a', Just 'x')]+    testGen "zipWithLongest (,) \"\" \"x\" == [(Nothing, Just 'x')]" $ zipWithLongest (,) "" "x" == [(Nothing, Just 'x')]+    testGen "comparingLength [1,2,3] [False] == GT" $ comparingLength [1,2,3] [False] == GT+    testGen "comparingLength [1,2] \"ab\" == EQ" $ comparingLength [1,2] "ab" == EQ+    testGen "\\(xs :: [Int]) (ys :: [Int]) -> comparingLength xs ys == Data.Ord.comparing length xs ys" $ \(xs :: [Int]) (ys :: [Int]) -> comparingLength xs ys == Data.Ord.comparing length xs ys+    testGen "comparingLength [1,2] (1:2:3:undefined) == LT" $ comparingLength [1,2] (1:2:3:undefined) == LT+    testGen "comparingLength (1:2:3:undefined) [1,2] == GT" $ comparingLength (1:2:3:undefined) [1,2] == GT+    testGen "mwhen True  \"test\" == \"test\"" $ mwhen True  "test" == "test"+    testGen "mwhen False \"test\" == \"\"" $ mwhen False "test" == ""     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")]@@ -258,6 +285,9 @@     testGen "(succ &&& pred) 1 == (2,0)" $ (succ &&& pred) 1 == (2,0)     testGen "dupe 12 == (12, 12)" $ dupe 12 == (12, 12)     testGen "both succ (1,2) == (2,3)" $ both succ (1,2) == (2,3)+    testGen "first3 succ (1,1,1) == (2,1,1)" $ first3 succ (1,1,1) == (2,1,1)+    testGen "second3 succ (1,1,1) == (1,2,1)" $ second3 succ (1,1,1) == (1,2,1)+    testGen "third3 succ (1,1,1) == (1,1,2)" $ third3 succ (1,1,1) == (1,1,2)     testGen "\\x -> readVersion (showVersion x) == x" $ \x -> readVersion (showVersion x) == x     testGen "readVersion \"hello\" == undefined" $ erroneous $ readVersion "hello"     testGen "showDP 4 pi == \"3.1416\"" $ showDP 4 pi == "3.1416"

@@ -14,7 +14,6 @@ import System.IO.Unsafe import Text.Show.Functions() -import Control.Applicative as X import Control.Concurrent.Extra as X import Control.Exception.Extra as X import Control.Monad.Extra as X@@ -25,9 +24,8 @@ import Data.List.Extra as X hiding (union, unionBy) import Data.List.NonEmpty.Extra as X (NonEmpty(..), (|>), (|:), appendl, appendr, union, unionBy) import Data.Maybe as X-import Data.Monoid as X+import Data.Monoid.Extra as X import Data.Tuple.Extra as X-import Data.Typeable.Extra as X import Data.Version.Extra as X import Numeric.Extra as X import System.Directory.Extra as X@@ -85,8 +83,8 @@ -- So we print out full information on failure instance (Show a, Eq a) => Eq (IO a) where     a == b = unsafePerformIO $ do-        a <- try_ $ captureOutput a-        b <- try_ $ captureOutput b+        a <- captureOutput $ try_ a+        b <- captureOutput $ try_ b         if a == b then pure True else             error $ show ("IO values not equal", a, b)