extra 1.6.13 → 1.8.1

raw patch · 29 files changed

Files

CHANGES.txt +83/−1
Generate.hs +39/−9
LICENSE +1/−1
README.md +8/−4
extra.cabal +10/−6
src/Control/Concurrent/Extra.hs +50/−71
src/Control/Exception/Extra.hs +35/−21
src/Control/Monad/Extra.hs +112/−29
src/Data/Either/Extra.hs +22/−13
src/Data/Foldable/Extra.hs +71/−0
src/Data/IORef/Extra.hs +8/−27
src/Data/List/Extra.hs +302/−92
src/Data/List/NonEmpty/Extra.hs +176/−0
src/Data/Monoid/Extra.hs +17/−0
src/Data/Tuple/Extra.hs +36/−1
src/Data/Typeable/Extra.hs +3/−122
src/Data/Version/Extra.hs +2/−13
src/Extra.hs +16/−20
src/Numeric/Extra.hs +2/−5
src/System/Directory/Extra.hs +7/−7
src/System/Environment/Extra.hs +4/−21
src/System/IO/Extra.hs +23/−17
src/System/Process/Extra.hs +1/−1
src/System/Time/Extra.hs +18/−17
src/Text/Read/Extra.hs +3/−32
test/Test.hs +1/−0
test/TestCustom.hs +22/−5
test/TestGen.hs +92/−35
test/TestUtil.hs +11/−16

CHANGES.txt view

@@ -1,5 +1,87 @@-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.6.20, released 2020-02-16+    Add firstM, secondM+1.6.19, released 2020-02-11+    #50, add headDef, lastDef, and dropEnd1+1.6.18, released 2019-08-21+    Make errorIO include a call stack+    Make maximumOn and minimumOn apply the function once per element+1.6.17, released 2019-05-31+    Add enumerate+1.6.16, released 2019-05-25+    Add atomicModifyIORef_ and atomicModifyIORef'_+1.6.15, released 2019-04-22+    #45, add NonEmpty.Extra for extra appending functions+    #42, add fromMaybeM+    Remove support for GHC 7.4, 7.6 and 7.8+1.6.14, released 2018-12-10+    Add mapLeft and mapRight 1.6.13, released 2018-10-14     #40, deprecate Data.List.Extra.for (clashes with Traversable) 1.6.12, released 2018-09-24

Generate.hs view

@@ -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,13 +23,13 @@ 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-        return (mod, funcs, tests)+        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"         ,"-- See Generate.hs for details of how to generate"@@ -37,18 +41,21 @@         ,"module Extra {-# DEPRECATED \"This module is provided as documentation of all new functions, you should import the more specific modules directly.\" #-} ("] ++         concat [ ["    -- * " ++ mod                  ,"    -- | Extra functions available in @" ++ show mod ++ "@."-                 ,"    " ++ unwords (map (++",") funs)]-               | (mod,funs,_) <- ifaces] +++                 ,"    " ++ unwords (map (++",") $ filter (notHidden mod) funs)]+               | (mod,funs@(_:_),_) <- ifaces] ++         ["    ) where"         ,""] ++-        ["import " ++ x | x <- mods]+        ["import " ++ addHiding mod | (mod,_:_,_) <- ifaces]     writeFileBinaryChanged "test/TestGen.hs" $ unlines $         ["-- 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.Ord"+        ,"import Test.QuickCheck.Instances.Semigroup ()"         ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))"         ,"tests :: IO ()"         ,"tests = do"] ++@@ -62,10 +69,33 @@ 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 +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" = words+    "cons snoc sortOn union unionBy nubOrd nubOrdBy nubOrdOn (!?) foldl1' repeatedly compareLength"+hidden _ = []++notHidden :: String -> String -> Bool+notHidden mod fun = fun `notElem` hidden mod++addHiding :: String -> String+addHiding mod+  | xs@(_:_) <- hidden mod = mod ++ " hiding (" ++ intercalate ", " xs ++ ")"+  | otherwise = mod  validIdentifier xs =     (take 1 xs == "(" || isName (takeWhile (/= '(') xs)) &&

LICENSE view

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

README.md view

@@ -1,11 +1,11 @@-# 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.2. A few examples:+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:  * `Control.Monad.Extra.concatMapM` provides a monadic version of `concatMap`, in the same way that `mapM` is a monadic version of `map`. * `Data.Tuple.Extra.fst3` provides a function to get the first element of a triple. * `Control.Exception.Extra.retry` provides a function that retries an `IO` action a number of times.-* `System.Environment.Extra.lookupEnv` is a function available in GHC 7.6 and above. On GHC 7.6 and above this package reexports the version from `System.Environment` while on GHC 7.4 and below it defines an equivalent version.+* `Data.Either.Extra.fromLeft` is a function available in GHC 8.0 and above. On GHC 8.0 and above this package reexports the version from `Data.Either` while on GHC 7.10 and below it defines an equivalent version.  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. @@ -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.

extra.cabal view

@@ -1,13 +1,13 @@-cabal-version:      >= 1.18+cabal-version:      1.18 build-type:         Simple name:               extra-version:            1.6.13+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-2018+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.6.1, GHC==8.4.3, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+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,7 +31,7 @@     default-language: Haskell2010     hs-source-dirs: src     build-depends:-        base >= 4.4 && < 5,+        base >= 4.9 && < 5,         directory,         filepath,         process,@@ -47,9 +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@@ -70,7 +73,8 @@         directory,         filepath,         extra,-        QuickCheck >= 2.10+        QuickCheck >= 2.10,+        quickcheck-instances >= 0.3.17     if !os(windows)         build-depends: unix     hs-source-dirs: test

src/Control/Concurrent/Extra.hs view

@@ -1,25 +1,28 @@-{-# LANGUAGE CPP, TupleSections, ConstraintKinds #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+{-# LANGUAGE TupleSections, ConstraintKinds #-}  -- | Extra functions for "Control.Concurrent". -- --   This module includes three new types of 'MVar', namely 'Lock' (no associated value), --   'Var' (never empty) and 'Barrier' (filled at most once). See---   <http://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 <http://hackage.haskell.org/package/slave-thread slave-thread> package.+--   see the <https://hackage.haskell.org/package/slave-thread slave-thread> package. --   If you need elaborate relationships between threads---   see the <http://hackage.haskell.org/package/async async> package.+--   see the <https://hackage.haskell.org/package/async async> package. module Control.Concurrent.Extra(     module Control.Concurrent,-    getNumCapabilities, setNumCapabilities, withNumCapabilities,-    forkFinally, once, onceFork,+    withNumCapabilities,+    once, onceFork,     -- * 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@@ -31,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'.@@ -43,60 +47,27 @@ withNumCapabilities _ act = act  -#if __GLASGOW_HASKELL__ < 702--- | A version of 'getNumCapabilities' that works on all versions of GHC, but returns 1 before GHC 7.2.-getNumCapabilities :: IO Int-getNumCapabilities = return 1-#endif--#if __GLASGOW_HASKELL__ < 706--- | A version of 'setNumCapabilities' that works on all versions of GHC, but has no effect before GHC 7.6.-setNumCapabilities :: Int -> IO ()-setNumCapabilities n = return ()-#endif---#if __GLASGOW_HASKELL__ < 706--- | fork a thread and call the supplied function when the thread is about--- to terminate, with an exception or a returned value.  The function is--- called with asynchronous exceptions masked.------ @--- 'forkFinally' action and_then =---    mask $ \restore ->---      forkIO $ try (restore action) >>= and_then--- @------ This function is useful for informing the parent when a child--- terminates, for example.-forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkFinally action and_then =-  mask $ \restore ->-    forkIO $ try (restore action) >>= and_then-#endif-- -- | Given an action, produce a wrapped action that runs at most once. --   If the function raises an exception, the same exception will be reraised each time. -- -- > 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@@ -110,7 +81,7 @@ onceFork act = do     bar <- newBarrier     forkFinally act $ signalBarrier bar-    return $ either throwIO return =<< waitBarrier bar+    pure $ eitherM throwIO pure $ waitBarrier bar   ---------------------------------------------------------------------@@ -122,7 +93,7 @@ -- -- @ -- lock <- 'newLock'--- let output = 'withLock' . putStrLn+-- let output = 'withLock' lock . putStrLn -- forkIO $ do ...; output \"hello\" -- forkIO $ do ...; output \"world\" -- @@@ -149,7 +120,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)   ---------------------------------------------------------------------@@ -184,16 +155,36 @@  -- | 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 +-- | 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@@ -216,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 -> return (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 -> return res-        Left bar -> do-            readMVar bar-            x <- readVar var-            case x of-                Right res -> return 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

src/Control/Exception/Extra.hs view

@@ -4,13 +4,16 @@ -- | Extra functions for "Control.Exception". --   These functions provide retrying, showing in the presence of exceptions, --   and functions to catch\/ignore exceptions, including monomorphic (no 'Exception' context) versions.+--+--   If you want to use a safer set of exceptions see the+--   <https://hackage.haskell.org/package/safe-exceptions safe-exceptions> package. module Control.Exception.Extra(     module Control.Exception,     Partial,     retry, retryBool,     errorWithoutStackTrace,     showException, stringException,-    errorIO, displayException,+    errorIO, assertIO,     -- * Exception catching/ignoring     ignore,     catch_, handle_, try_,@@ -18,6 +21,10 @@     catchBool, handleBool, tryBool     ) where +#if __GLASGOW_HASKELL__ >= 800+import GHC.Stack+#endif+ import Control.Exception import Control.Monad import Data.List.Extra@@ -28,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  @@ -49,13 +56,6 @@ showException = stringException . show  -#if __GLASGOW_HASKELL__ < 710--- | Render this exception value in a human-friendly manner.---   Part of the 'Exception' class in GHC 7.10 onwards.-displayException :: Exception e => e -> String-displayException = show-#endif- #if __GLASGOW_HASKELL__ < 800 -- | A variant of 'error' that does not produce a stack trace. errorWithoutStackTrace :: String -> a@@ -66,19 +66,33 @@ -- | 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_  --- | Like error, but in the 'IO' monad.---   Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception.+-- | 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. ----- > try (errorIO "Hello") == return (Left (ErrorCall "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 = throwIO . ErrorCall+errorIO x = withFrozenCallStack $ evaluate $ error x +#if __GLASGOW_HASKELL__ < 800+withFrozenCallStack :: a -> a+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. --@@ -97,7 +111,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',@@ -129,7 +143,7 @@ --   As an example: -- -- @--- readFileExists x == catchBool isDoesNotExistError (readFile \"myfile\") (const $ return \"\")+-- readFileExists x == catchBool isDoesNotExistError (readFile \"myfile\") (const $ pure \"\") -- @ catchBool :: Exception e => (e -> Bool) -> IO a -> (e -> IO a) -> IO a catchBool f a b = catchJust (bool f) a b

src/Control/Monad/Extra.hs view

@@ -3,15 +3,17 @@ -- | Extra functions for "Control.Monad". --   These functions provide looping, list operations and booleans. --   If you need a wider selection of monad loops and list generalisations,---   see <http://hackage.haskell.org/package/monad-loops monad-loops>.+--   see <https://hackage.haskell.org/package/monad-loops monad-loops>. module Control.Monad.Extra(     module Control.Monad,     whenJust, whenJustM,+    pureIf,     whenMaybe, whenMaybeM,     unit,-    maybeM, eitherM,+    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,62 +31,106 @@ -- General utilities  -- | Perform some operation on 'Just', given the field inside the 'Just'.+--   This is a specialized 'Data.Foldable.for_'. ----- > whenJust Nothing  print == return ()+-- > 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 = maybe (return ()) f =<< mg+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) == return Nothing+-- > 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 return Nothing-+    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 >> return ()+fold1M_ f xs = fold1M f xs >> pure ()   -- Data.List for Monad@@ -93,34 +139,37 @@ -- -- > 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 [] = 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.+{-# 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  -- | 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 @@ -128,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@@ -135,12 +185,13 @@  -- | 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     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: --@@ -150,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 (return ())+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 (return ()) f+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 @@ -180,8 +258,9 @@ -- > 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 (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@@ -190,32 +269,34 @@ -- > 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 (return False)+(&&^) a b = ifM a b (pure False)  -- | A version of 'any' lifted to a monad. Retains the short-circuiting behaviour. -- -- > 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 [] = return False-anyM p (x:xs) = ifM (p x) (return True) (anyM p xs)+anyM p = foldr ((||^) . p) (pure False)  -- | A version of 'all' lifted to a monad. Retains the short-circuiting behaviour. -- -- > 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 [] = return True-allM p (x:xs) = ifM (p x) (allM p xs) (return False)+allM p = foldr ((&&^) . p) (pure True)  -- | A version of 'or' lifted to a monad. Retains the short-circuiting behaviour. -- -- > 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 @@ -224,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 @@ -234,11 +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 [] = return Nothing-findM p (x:xs) = ifM (p x) (return $ Just x) (findM p xs)+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 [] = return Nothing-firstJustM p (x:xs) = maybe (firstJustM p xs) (return . Just) =<< p x+firstJustM p [] = pure Nothing+firstJustM p (x:xs) = maybeM (firstJustM p xs) (pure . Just) (p x)

src/Data/Either/Extra.hs view

@@ -4,11 +4,15 @@ -- | This module extends "Data.Either" with extra operations, particularly --   to quickly extract from inside an 'Either'. Some of these operations are --   partial, and should be used with care in production-quality code.+--+--   If you need more 'Either' functions see the+--   <https://hackage.haskell.org/package/either either>. module Data.Either.Extra(     module Data.Either,-    isLeft, isRight, fromLeft, fromRight, fromEither,+    fromLeft, fromRight, fromEither,     fromLeft', fromRight',     eitherToMaybe, maybeToEither,+    mapLeft, mapRight,     ) where  import Data.Either@@ -57,18 +61,6 @@ fromRight' _ = error "fromRight', given a Left"  -#if __GLASGOW_HASKELL__ < 708--- | Test if an 'Either' value is the 'Left' constructor.---   Provided as standard with GHC 7.8 and above.-isLeft :: Either l r -> Bool-isLeft Left{} = True; isLeft _ = False---- | Test if an 'Either' value is the 'Right' constructor.---   Provided as standard with GHC 7.8 and above.-isRight :: Either l r -> Bool-isRight Right{} = True; isRight _ = False-#endif- -- | Pull the value out of an 'Either' where both alternatives --   have the same type. --@@ -93,3 +85,20 @@ -- > \x -> eitherToMaybe (Right x) == Just x eitherToMaybe :: Either a b -> Maybe b eitherToMaybe = either (const Nothing) Just+++-- | The 'mapLeft' function takes a function and applies it to an Either value+-- iff the value takes the form @'Left' _@.+--+-- > mapLeft show (Left 1) == Left "1"+-- > mapLeft show (Right True) == Right True+mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f = either (Left . f) Right++-- | The 'mapRight' function takes a function and applies it to an Either value+-- iff the value takes the form @'Right' _@.+--+-- > mapRight show (Left 1) == Left 1+-- > mapRight show (Right True) == Right "True"+mapRight :: (b -> c) -> Either a b -> Either a c+mapRight = fmap

+ src/Data/Foldable/Extra.hs view

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

src/Data/IORef/Extra.hs view

@@ -1,11 +1,10 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}  -- | This module extends "Data.IORef" with operations forcing the value written to the IORef. --   Some of these functions are available in later versions of GHC, but not all. module Data.IORef.Extra(     module Data.IORef,-    modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef'+    writeIORef', atomicWriteIORef',+    atomicModifyIORef_, atomicModifyIORef'_     ) where  import Data.IORef@@ -25,28 +24,10 @@     atomicWriteIORef ref x  -#if __GLASGOW_HASKELL__ < 706---- | Version of 'modifyIORef' that evaluates the function.-modifyIORef' :: IORef a -> (a -> a) -> IO ()-modifyIORef' ref f = do-    x <- readIORef ref-    writeIORef' ref $ f x---- | Strict version of 'atomicModifyIORef'.  This forces both the value stored--- in the 'IORef' as well as the value returned.-atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORef' ref f = do-    b <- atomicModifyIORef ref-            (\x -> let (a, b) = f x-                    in (a, a `seq` b))-    b `seq` return b---- | Variant of 'writeIORef' with the \"barrier to reordering\" property that--- 'atomicModifyIORef' has.-atomicWriteIORef :: IORef a -> a -> IO ()-atomicWriteIORef ref a = do-    x <- atomicModifyIORef ref $ const (a, ())-    x `seq` return ()+-- | Variant of 'atomicModifyIORef' which ignores the return value+atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef_ r f = atomicModifyIORef r $ \v -> (f v, ()) -#endif+-- | Variant of 'atomicModifyIORef'' which ignores the return value+atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef'_ r f = atomicModifyIORef' r $ \v -> (f v, ())

src/Data/List/Extra.hs view

@@ -1,10 +1,10 @@-{-# LANGUAGE CPP, 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. --   Some of the names and semantics were inspired by the---   <http://hackage.haskell.org/package/text text> package.+--   <https://hackage.haskell.org/package/text text> package. module Data.List.Extra(     module Data.List,     -- * String operations@@ -13,23 +13,28 @@     unescapeHTML, unescapeJSON,     -- * Splitting     dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd,-    dropWhileEnd, dropWhileEnd', takeWhileEnd,+    dropWhileEnd', takeWhileEnd,     stripSuffix, stripInfix, stripInfixEnd,     dropPrefix, dropSuffix,     wordsBy, linesBy,     breakOn, breakOnEnd, splitOn, split, chunksOf,     -- * Basics-    notNull, list, uncons, unsnoc, cons, snoc, drop1, 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, sortOn,+    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 @@ -42,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@@ -56,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@@ -71,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@@ -97,6 +138,41 @@ allSame (x:xs) = all (x ==) xs  +-- | A total 'head' with a default value.+--+-- > headDef 1 []      == 1+-- > headDef 1 [2,3,4] == 2+-- > \x xs -> headDef x xs == fromMaybe x (listToMaybe xs)+headDef :: a -> [a] -> a+headDef d [] = d+headDef _ (x:_) = x+++-- | A total 'last' with a default value.+--+-- > lastDef 1 []      == 1+-- > lastDef 1 [2,3,4] == 4+-- > \x xs -> lastDef x xs == last (x:xs)+lastDef :: a -> [a] -> a+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'. -- -- > notNull []  == False@@ -114,17 +190,7 @@ list nil cons [] = nil list nil cons (x:xs) = cons x xs -#if __GLASGOW_HASKELL__ < 709--- | If the list is empty returns 'Nothing', otherwise returns the 'head' and the 'tail'.------ > uncons "test" == Just ('t',"est")--- > uncons ""     == Nothing--- > \xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs)-uncons :: [a] -> Maybe (a, [a])-uncons [] = Nothing-uncons (x:xs) = Just (x,xs)-#endif-+#if __GLASGOW_HASKELL__ <= 906 -- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'. -- -- > unsnoc "test" == Just ("tes",'t')@@ -135,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 '(:)'. --@@ -151,6 +218,12 @@ snoc xs x = xs ++ [x]  +-- | Enumerate all the values of an 'Enum', from 'minBound' to 'maxBound'.+--+-- > enumerate == [False, True]+enumerate :: (Enum a, Bounded a) => [a]+enumerate = [minBound..maxBound]+ -- | Take a number of elements from the end of the list. -- -- > takeEnd 3 "hello"  == "llo"@@ -159,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 @@ -172,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 _ _ = [] @@ -185,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'. --@@ -272,7 +349,7 @@ -- > \s -> fst (word1 s) == concat (take 1 $ words s) -- > \s -> words (snd $ word1 s) == drop 1 (words s) word1 :: String -> (String, String)-word1 = second (dropWhile isSpace) . break isSpace . dropWhile isSpace+word1 = second trimStart . break isSpace . trimStart  -- | Split the first line off a string. --@@ -353,39 +430,65 @@ unescapeJSON [] = []  -#if __GLASGOW_HASKELL__ < 709--- | Sort a list by comparing the results of a key function applied to each--- element.  @sortOn f@ is equivalent to @sortBy (comparing f)@, but has the--- performance advantage of only evaluating @f@ once for each element in the--- input list.  This is called the decorate-sort-undecorate paradigm, or--- Schwartzian transform.------ > sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")]-sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f = map snd . sortBy (compare `on` fst) . map (\x -> let y = f x in y `seq` (y, x))-#endif- -- | A version of 'group' where the equality is done on some extracted value.-groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+--+-- > groupOn 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 'nub' where the equality is done on some extracted value.+-- | 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. --   @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))  -- | A version of 'maximum' where the comparison is done on some extracted value.-maximumOn :: Ord b => (a -> b) -> [a] -> a-maximumOn f = maximumBy (compare `on` f)+--   Raises an error if the list is empty. Only calls the function once per element.+--+-- > maximumOn id [] == undefined+-- > maximumOn length ["test","extra","a"] == "extra"+maximumOn :: (Partial, Ord b) => (a -> b) -> [a] -> a+maximumOn f [] = error "Data.List.Extra.maximumOn: empty list"+maximumOn f (x:xs) = g x (f x) xs+    where+        g v mv [] = v+        g v mv (x:xs) | mx > mv = g x mx xs+                      | otherwise = g v mv xs+            where mx = f x + -- | A version of 'minimum' where the comparison is done on some extracted value.-minimumOn :: Ord b => (a -> b) -> [a] -> a-minimumOn f = minimumBy (compare `on` f)+--   Raises an error if the list is empty. Only calls the function once per element.+--+-- > minimumOn id [] == undefined+-- > minimumOn length ["test","extra","a"] == "a"+minimumOn :: (Partial, Ord b) => (a -> b) -> [a] -> a+minimumOn f [] = error "Data.List.Extra.minimumOn: empty list"+minimumOn f (x:xs) = g x (f x) xs+    where+        g v mv [] = v+        g v mv (x:xs) | mx < mv = g x mx xs+                      | otherwise = g v mv xs+            where mx = f x  -- | A combination of 'group' and 'sort'. --@@ -393,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. --@@ -408,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"@@ -425,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 [] = []@@ -505,6 +637,16 @@ drop1 (x:xs) = xs  +-- | Equivalent to @dropEnd 1@, but likely to be faster and a single lexeme.+--+-- > dropEnd1 ""         == ""+-- > dropEnd1 "test"     == "tes"+-- > \xs -> dropEnd 1 xs == dropEnd1 xs+dropEnd1 :: [a] -> [a]+dropEnd1 [] = []+dropEnd1 (x:xs) = foldr (\z f y -> y : f z) (const []) xs x++ -- | Version on `concatMap` generalised to a `Monoid` rather than just a list. -- -- > mconcatMap Sum [1,2,3] == Sum 6@@ -571,12 +713,6 @@ split f (x:xs) | y:ys <- split f xs = (x:y) : ys  -#if __GLASGOW_HASKELL__ < 704-dropWhileEnd :: (a -> Bool) -> [a] -> [a]-dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []-#endif-- -- | A version of 'dropWhileEnd' but with different strictness properties. --   The function 'dropWhileEnd' can be used on an infinite list and tests the property --   on each character. In contrast, 'dropWhileEnd'' is strict in the spine of the list@@ -680,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@@ -690,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. --@@ -697,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"]@@ -705,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 http://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs+-- 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

+ src/Data/List/NonEmpty/Extra.hs view

@@ -0,0 +1,176 @@+{-# 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, (!?),+    appendl, appendr,+    sortOn, union, unionBy,+    nubOrd, nubOrdBy, nubOrdOn,+    maximum1, minimum1, maximumBy1, minimumBy1, maximumOn1, minimumOn1,+    foldl1', repeatedly,+    compareLength+    ) where++import           Data.Function+import qualified Data.List.Extra as List+import           Data.List.NonEmpty++#if __GLASGOW_HASKELL__ <= 802+import Data.Semigroup ((<>))+#endif++infixl 5 |>, |:++-- | /O(n)/. Append an element to a non-empty list.+--+-- > (1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5]+(|>) :: NonEmpty a -> a -> NonEmpty a+(|>) xs x = xs <> pure x++-- | Synonym for '|>'.+snoc :: NonEmpty a -> a -> NonEmpty a+snoc = (|>)++-- | /O(n)/. Append an element to a list.+--+-- > [1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5]+(|:) :: [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]+appendl :: NonEmpty a -> [a] -> NonEmpty a+appendl (x :| xs) l = x :| (xs ++ l)++-- | Append a non-empty list to a list.+--+-- > appendr [1,2,3] (4 :| [5]) == 1 :| [2,3,4,5]+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+--   contains duplicates, so will the result.+--+-- > (1 :| [3, 5, 3]) `union` (4 :| [5, 3, 5, 2]) == 1 :| [3, 5, 3, 4, 2]+union :: Eq a => NonEmpty a -> NonEmpty a -> NonEmpty a+union = unionBy (==)++#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'.+--+-- > 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)++-- | The largest element of a non-empty list.+maximum1 :: Ord a => NonEmpty a -> a+maximum1 = List.maximum++-- | The least element of a non-empty list.+minimum1 :: Ord a => NonEmpty a -> a+minimum1 = List.minimum++-- | The largest element of a non-empty list with respect to the given+--   comparison function.+maximumBy1 :: (a -> a -> Ordering) -> NonEmpty a -> a+maximumBy1 = List.maximumBy++-- | The least element of a non-empty list with respect to the given+--   comparison function.+minimumBy1 :: (a -> a -> Ordering) -> NonEmpty a -> a+minimumBy1 = List.minimumBy++-- | A version of 'maximum1' where the comparison is done on some extracted value.+maximumOn1 :: Ord b => (a -> b) -> NonEmpty a -> a+maximumOn1 f = maximumBy1 (compare `on` f)++-- | 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

+ src/Data/Monoid/Extra.hs view

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

src/Data/Tuple/Extra.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-}  -- | Extra functions for working with pairs and triples. --   Some of these functions are available in the "Control.Arrow" module,@@ -8,8 +9,11 @@     first, second, (***), (&&&),     -- * More pair operations     dupe, both,+    -- * Monadic versions+    firstM, secondM,     -- * Operations on triple     fst3, snd3, thd3,+    first3, second3, third3,     curry3, uncurry3     ) where @@ -30,6 +34,18 @@ second :: (b -> b') -> (a, b) -> (a, b') second = Arrow.second +-- | Update the first component of a pair.+--+-- > 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++-- | 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+ -- | Given two functions, apply one to the first component and one to the second. --   A specialised version of 'Control.Arrow.***'. --@@ -54,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@@ -75,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)

src/Data/Typeable/Extra.hs view

@@ -1,129 +1,10 @@-{-# LANGUAGE CPP, ScopedTypeVariables, TypeOperators, GADTs, StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}  -- | This module extends "Data.Typeable" with extra functions available in later GHC versions. --   The package also exports the existing "Data.Typeable" functions.-module Data.Typeable.Extra(-    typeRep, (:~:)(..), Proxy(..),+--+--   Currently this module has no functionality beyond "Data.Typeable".+module Data.Typeable.Extra {-# DEPRECATED "Use Data.Typeable directly" #-} (     module Data.Typeable     ) where  import Data.Typeable--#if __GLASGOW_HASKELL__ < 708--import Data.Ix-import Data.Monoid-import Control.Monad-import Control.Applicative----- | Takes a value of type @a@ and returns a concrete representation---   of that type.------ > typeRep (Proxy :: Proxy Int) == typeOf (1 :: Int)-typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep-typeRep _ = typeOf (undefined :: a)---infix 4 :~:---- | Propositional equality. If @a :~: b@ is inhabited by some terminating--- value, then the type @a@ is the same as the type @b@. To use this equality--- in practice, pattern-match on the @a :~: b@ to get out the @Refl@ constructor;--- in the body of the pattern-match, the compiler knows that @a ~ b@.-data a :~: b where-    Refl :: a :~: a--deriving instance Eq   (a :~: b)-deriving instance Show (a :~: b)-deriving instance Ord  (a :~: b)--instance a ~ b => Read (a :~: b) where-  readsPrec d = readParen (d > 10) (\r -> [(Refl, s) | ("Refl",s) <- lex r ])--instance a ~ b => Enum (a :~: b) where-  toEnum 0 = Refl-  toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument"--  fromEnum Refl = 0--instance a ~ b => Bounded (a :~: b) where-  minBound = Refl-  maxBound = Refl------ | A canonical proxy type-data Proxy t = Proxy---- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t)--- interchangeably, so all of these instances are hand-written to be--- lazy in Proxy arguments.--instance Eq (Proxy s) where-  _ == _ = True--instance Ord (Proxy s) where-  compare _ _ = EQ--instance Show (Proxy s) where-  showsPrec _ _ = showString "Proxy"--instance Read (Proxy s) where-  readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ])--errorWithoutStackTrace = error--instance Enum (Proxy s) where-    succ _               = errorWithoutStackTrace "Proxy.succ"-    pred _               = errorWithoutStackTrace "Proxy.pred"-    fromEnum _           = 0-    toEnum 0             = Proxy-    toEnum _             = errorWithoutStackTrace "Proxy.toEnum: 0 expected"-    enumFrom _           = [Proxy]-    enumFromThen _ _     = [Proxy]-    enumFromThenTo _ _ _ = [Proxy]-    enumFromTo _ _       = [Proxy]--instance Ix (Proxy s) where-    range _           = [Proxy]-    index _ _         = 0-    inRange _ _       = True-    rangeSize _       = 1--instance Bounded (Proxy s) where-    minBound = Proxy-    maxBound = Proxy--instance Monoid (Proxy s) where-    mempty = Proxy-    mappend _ _ = Proxy-    mconcat _ = Proxy--instance Functor Proxy where-    fmap _ _ = Proxy-    {-# INLINE fmap #-}--instance Applicative Proxy where-    pure _ = Proxy-    {-# INLINE pure #-}-    _ <*> _ = Proxy-    {-# INLINE (<*>) #-}--instance Alternative Proxy where-    empty = Proxy-    {-# INLINE empty #-}-    _ <|> _ = Proxy-    {-# INLINE (<|>) #-}--instance Monad Proxy where-    return = pure-    _ >>= _ = Proxy-    {-# INLINE (>>=) #-}--instance MonadPlus Proxy where-    mzero = empty-    mplus = (<|>)--#endif

src/Data/Version/Extra.hs view

@@ -1,11 +1,10 @@-{-# LANGUAGE CPP, ConstraintKinds #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}+{-# LANGUAGE ConstraintKinds #-}  -- | This module extends "Data.Version" with extra utilities. --   The package also exports the existing "Data.Version" functions. module Data.Version.Extra(     module Data.Version,-    makeVersion, readVersion+    readVersion     ) where  import Partial@@ -13,16 +12,6 @@ import Data.List.Extra import Text.ParserCombinators.ReadP --#if __GLASGOW_HASKELL__ < 710---- | Construct tag-less 'Version'------ > showVersion (makeVersion [1,2,3]) == "1.2.3"-makeVersion :: [Int] -> Version-makeVersion b = Version b []--#endif  -- | Read a 'Version' or throw an exception. --

src/Extra.hs view

@@ -8,40 +8,40 @@ 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"@.-    getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, 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, displayException, 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, 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"@.-    isLeft, isRight, fromLeft, fromRight, fromEither, fromLeft', fromRight', eitherToMaybe, maybeToEither,+    fromLeft, fromRight, fromEither, fromLeft', fromRight', eitherToMaybe, maybeToEither, mapLeft, mapRight,     -- * Data.IORef.Extra     -- | Extra functions available in @"Data.IORef.Extra"@.-    modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef',+    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, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, notNull, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, 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, fst3, snd3, thd3, curry3, uncurry3,-    -- * Data.Typeable.Extra-    -- | Extra functions available in @"Data.Typeable.Extra"@.-    typeRep, (:~:)(..), Proxy(..),+    first, second, (***), (&&&), dupe, both, firstM, secondM, fst3, snd3, thd3, first3, second3, third3, curry3, uncurry3,     -- * Data.Version.Extra     -- | Extra functions available in @"Data.Version.Extra"@.-    makeVersion, readVersion,+    readVersion,     -- * Numeric.Extra     -- | Extra functions available in @"Numeric.Extra"@.     showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat,     -- * System.Directory.Extra     -- | Extra functions available in @"System.Directory.Extra"@.     withCurrentDirectory, createDirectoryPrivate, listContents, listDirectories, listFiles, listFilesInside, listFilesRecursive,-    -- * System.Environment.Extra-    -- | Extra functions available in @"System.Environment.Extra"@.-    getExecutablePath, lookupEnv,     -- * System.Info.Extra     -- | Extra functions available in @"System.Info.Extra"@.     isWindows, isMac,@@ -54,9 +54,6 @@     -- * System.Time.Extra     -- | Extra functions available in @"System.Time.Extra"@.     Seconds, sleep, timeout, showDuration, offsetTime, offsetTimeIncrease, duration,-    -- * Text.Read.Extra-    -- | Extra functions available in @"Text.Read.Extra"@.-    readEither, readMaybe,     ) where  import Control.Concurrent.Extra@@ -65,14 +62,13 @@ 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, (!?), foldl1', repeatedly, compareLength)+import Data.Monoid.Extra import Data.Tuple.Extra-import Data.Typeable.Extra import Data.Version.Extra import Numeric.Extra import System.Directory.Extra-import System.Environment.Extra import System.Info.Extra import System.IO.Extra import System.Process.Extra import System.Time.Extra-import Text.Read.Extra

src/Numeric/Extra.hs view

@@ -7,8 +7,8 @@     ) where  import Numeric-import Control.Arrow + --------------------------------------------------------------------- -- Data.String @@ -18,8 +18,7 @@ -- > showDP 0 pi == "3" -- > showDP 2 3  == "3.00" showDP :: RealFloat a => Int -> a -> String-showDP n x = a ++ (if n > 0 then "." else "") ++ b ++ replicate (n - length b) '0'-    where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x ""+showDP n x = showFFloat (Just n) x ""   ---------------------------------------------------------------------@@ -40,5 +39,3 @@ -- | Specialised numeric conversion, type restricted version of 'realToFrac'. doubleToFloat :: Double -> Float doubleToFloat = realToFrac--

src/System/Directory/Extra.hs view

@@ -52,12 +52,12 @@ -- -- > withTempDir $ \dir -> do writeFile (dir </> "test.txt") ""; (== [dir </> "test.txt"]) <$> listContents dir -- > let touch = mapM_ $ \x -> createDirectoryIfMissing True (takeDirectory x) >> writeFile x ""--- > let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir </>) as; res <- op dir; return $ map (drop (length dir + 1)) res == bs+-- > let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir </>) as; res <- op dir; pure $ map (drop (length dir + 1)) res == bs -- > listTest listContents ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","foo","zoo"] listContents :: FilePath -> IO [FilePath] listContents dir = do     xs <- getDirectoryContents dir-    return $ sort [dir </> x | x <- xs, not $ all (== '.') x]+    pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]   -- | Like 'listContents', but only returns the directories in a directory, not the files.@@ -81,21 +81,21 @@ -- -- > listTest listFilesRecursive ["bar.txt","zoo","foo" </> "baz.txt"] ["bar.txt","zoo","foo" </> "baz.txt"] listFilesRecursive :: FilePath -> IO [FilePath]-listFilesRecursive = listFilesInside (const $ return True)+listFilesRecursive = listFilesInside (const $ pure True)   -- | Like 'listFilesRecursive', but with a predicate to decide where to recurse into. --   Typically directories starting with @.@ would be ignored. The initial argument directory --   will have the test applied to it. ----- > listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName)+-- > listTest (listFilesInside $ pure . not . isPrefixOf "." . takeFileName) -- >     ["bar.txt","foo" </> "baz.txt",".foo" </> "baz2.txt", "zoo"] ["bar.txt","zoo","foo" </> "baz.txt"]--- > listTest (listFilesInside $ const $ return False) ["bar.txt"] []+-- > listTest (listFilesInside $ const $ pure False) ["bar.txt"] [] listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]-listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (return []) $ do+listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do     (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir     rest <- concatMapM (listFilesInside test) dirs-    return $ files ++ rest+    pure $ files ++ rest   -- | Create a directory with permissions so that only the current user can view it.

src/System/Environment/Extra.hs view

@@ -1,26 +1,9 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Extra functions for "System.Environment". All these functions are available in later GHC versions,---   but this code works all the way back to GHC 7.2.-module System.Environment.Extra(+-- | Extra functions for "System.Environment".+--+--   Currently this module has no functionality beyond "System.Environment".+module System.Environment.Extra  {-# DEPRECATED "Use System.Environment directly" #-} (     module System.Environment,-    getExecutablePath, lookupEnv     ) where  import System.Environment--#if __GLASGOW_HASKELL__ < 706-import Control.Exception.Extra-import System.IO.Error-import Data.Functor---- | Alias for 'getProgName' in GHC 7.4 and below, otherwise---   returns the absolute pathname of the current executable.-getExecutablePath :: IO FilePath-getExecutablePath = getProgName---- | Return the value of the environment variable var, or Nothing if there is no such value.-lookupEnv :: String -> IO (Maybe String)-lookupEnv x = catchBool isDoesNotExistError (Just <$> getEnv x) (const $ return Nothing)-#endif

src/System/IO/Extra.hs view

@@ -1,9 +1,10 @@-{-# 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 --   temporary file functions, more advanced alternatives can be found in---   the <http://hackage.haskell.org/package/exceptions exceptions> package.+--   the <https://hackage.haskell.org/package/exceptions exceptions> package. module System.IO.Extra(     module System.IO,     captureOutput,@@ -61,12 +62,15 @@  -- 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     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.@@ -76,6 +80,8 @@ 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 readFileEncoding' e file = withFile file ReadMode $ \h -> hSetEncoding h e >> hGetContents' h@@ -112,7 +118,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 +126,7 @@             hClose h             act         out <- readFile' file-        return (out, res)+        pure (out, res)     where         clone out h act = do             buf <- hGetBuffering out@@ -166,13 +172,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 +186,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 +206,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 +241,8 @@             r1 <- hGetBuf h1 b1 bufsz             r2 <- hGetBuf h2 b2 bufsz             if r1 == 0-                then return $ r2 == 0-                else return (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2+                then pure $ r2 == 0+                else pure (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2           bufeq b1 b2 s = (==0) <$> memcmp b1 b2 (fromIntegral s)           withb = allocaBytesAligned bufsz 4096           bufsz = 64*1024

src/System/Process/Extra.hs view

@@ -40,4 +40,4 @@     (res,out) <- systemOutput x     when (res /= ExitSuccess) $         error $ "Failed when running system command: " ++ x-    return out+    pure out

src/System/Time/Extra.hs view

@@ -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@@ -26,18 +27,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 +53,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 +91,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 +108,10 @@  -- | Record how long a computation takes in 'Seconds'. ----- > do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.5-duration :: IO a -> IO (Seconds, a)+-- > do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5+duration :: MonadIO m => m a -> m (Seconds, a) duration act = do-    time <- offsetTime+    time <- liftIO offsetTime     res <- act-    time <- time-    return (time, res)+    time <- liftIO time+    pure (time, res)

src/Text/Read/Extra.hs view

@@ -1,38 +1,9 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}  -- | This module provides "Text.Read" with functions added in later versions.-module Text.Read.Extra(+--+--   Currently this module has no functionality beyond "Text.Read".+module Text.Read.Extra {-# DEPRECATED "Use Text.Read directly" #-} (     module Text.Read,-    readEither, readMaybe     ) where  import Text.Read--#if __GLASGOW_HASKELL__ < 706--import Text.ParserCombinators.ReadP as P---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.--- A 'Left' value indicates a parse error.-readEither :: Read a => String -> Either String a-readEither s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Right x-    []  -> Left "Prelude.read: no parse"-    _   -> Left "Prelude.read: ambiguous parse"- where-  read' =-    do x <- readPrec-       lift P.skipSpaces-       return x---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.-readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of-                Left _  -> Nothing-                Right a -> Just a--#endif

test/Test.hs view

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

test/TestCustom.hs view

@@ -1,29 +1,37 @@ -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-            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"@@ -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 ()

test/TestGen.hs view

@@ -1,33 +1,49 @@ -- 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.Ord+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 "try (errorIO \"Hello\") == return (Left (ErrorCall \"Hello\"))" $ try (errorIO "Hello") == return (Left (ErrorCall "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 "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 == 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 "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) == 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 "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])@@ -68,11 +84,19 @@     testGen "\\a -> maybeToEither a Nothing == Left a" $ \a -> maybeToEither a Nothing == Left a     testGen "\\x -> eitherToMaybe (Left x) == Nothing" $ \x -> eitherToMaybe (Left x) == Nothing     testGen "\\x -> eitherToMaybe (Right x) == Just x" $ \x -> eitherToMaybe (Right x) == Just x+    testGen "mapLeft show (Left 1) == Left \"1\"" $ mapLeft show (Left 1) == Left "1"+    testGen "mapLeft show (Right True) == Right True" $ mapLeft show (Right True) == Right True+    testGen "mapRight show (Left 1) == Left 1" $ mapRight show (Left 1) == Left 1+    testGen "mapRight show (Right True) == Right \"True\"" $ mapRight show (Right True) == Right "True"     testGen "\\xs -> repeatedly (splitAt 3) xs  == chunksOf 3 xs" $ \xs -> repeatedly (splitAt 3) xs  == chunksOf 3 xs     testGen "\\xs -> repeatedly word1 (trim xs) == words xs" $ \xs -> repeatedly word1 (trim xs) == words xs     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@@ -84,15 +108,21 @@     testGen "allSame []      == True" $ allSame []      == True     testGen "allSame (1:1:2:undefined) == False" $ allSame (1:1:2:undefined) == False     testGen "\\xs -> allSame xs == (length (nub xs) <= 1)" $ \xs -> allSame xs == (length (nub xs) <= 1)+    testGen "headDef 1 []      == 1" $ headDef 1 []      == 1+    testGen "headDef 1 [2,3,4] == 2" $ headDef 1 [2,3,4] == 2+    testGen "\\x xs -> headDef x xs == fromMaybe x (listToMaybe xs)" $ \x xs -> headDef x xs == fromMaybe x (listToMaybe xs)+    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)     testGen "list 1 (\\v _ -> v - 2) [5,6,7] == 3" $ list 1 (\v _ -> v - 2) [5,6,7] == 3     testGen "list 1 (\\v _ -> v - 2) []      == 1" $ list 1 (\v _ -> v - 2) []      == 1     testGen "\\nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs" $ \nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs-    testGen "uncons \"test\" == Just ('t',\"est\")" $ uncons "test" == Just ('t',"est")-    testGen "uncons \"\"     == Nothing" $ uncons ""     == Nothing-    testGen "\\xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs)" $ \xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs)     testGen "unsnoc \"test\" == Just (\"tes\",'t')" $ unsnoc "test" == Just ("tes",'t')     testGen "unsnoc \"\"     == Nothing" $ unsnoc ""     == Nothing     testGen "\\xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs)" $ \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs)@@ -100,6 +130,7 @@     testGen "\\x xs -> uncons (cons x xs) == Just (x,xs)" $ \x xs -> uncons (cons x xs) == Just (x,xs)     testGen "snoc \"tes\" 't' == \"test\"" $ snoc "tes" 't' == "test"     testGen "\\xs x -> unsnoc (snoc xs x) == Just (xs,x)" $ \xs x -> unsnoc (snoc xs x) == Just (xs,x)+    testGen "enumerate == [False, True]" $ enumerate == [False, True]     testGen "takeEnd 3 \"hello\"  == \"llo\"" $ takeEnd 3 "hello"  == "llo"     testGen "takeEnd 5 \"bye\"    == \"bye\"" $ takeEnd 5 "bye"    == "bye"     testGen "takeEnd (-1) \"bye\" == \"\"" $ takeEnd (-1) "bye" == ""@@ -116,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")@@ -147,18 +178,28 @@     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 "sortOn fst [(3,\"z\"),(1,\"\"),(3,\"a\")] == [(1,\"\"),(3,\"z\"),(3,\"a\")]" $ sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")]+    testGen "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 []+    testGen "minimumOn length [\"test\",\"extra\",\"a\"] == \"a\"" $ minimumOn length ["test","extra","a"] == "a"     testGen "groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,\"t\"),(2,\"es\"),(3,\"t\")]" $ groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,"t"),(2,"es"),(3,"t")]     testGen "\\xs -> map fst (groupSort xs) == sort (nub (map fst xs))" $ \xs -> map fst (groupSort xs) == sort (nub (map fst xs))     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")@@ -177,6 +218,9 @@     testGen "drop1 \"\"         == \"\"" $ drop1 ""         == ""     testGen "drop1 \"test\"     == \"est\"" $ drop1 "test"     == "est"     testGen "\\xs -> drop 1 xs == drop1 xs" $ \xs -> drop 1 xs == drop1 xs+    testGen "dropEnd1 \"\"         == \"\"" $ dropEnd1 ""         == ""+    testGen "dropEnd1 \"test\"     == \"tes\"" $ dropEnd1 "test"     == "tes"+    testGen "\\xs -> dropEnd 1 xs == dropEnd1 xs" $ \xs -> dropEnd 1 xs == dropEnd1 xs     testGen "mconcatMap Sum [1,2,3] == Sum 6" $ mconcatMap Sum [1,2,3] == Sum 6     testGen "\\f xs -> mconcatMap f xs == concatMap f xs" $ \f xs -> mconcatMap f xs == concatMap f xs     testGen "breakOn \"::\" \"a::b::c\" == (\"a\", \"::b::c\")" $ breakOn "::" "a::b::c" == ("a", "::b::c")@@ -223,14 +267,27 @@     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 "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")]+    testGen "secondM (\\x -> [reverse x, x]) (1,\"test\") == [(1,\"tset\"),(1,\"test\")]" $ secondM (\x -> [reverse x, x]) (1,"test") == [(1,"tset"),(1,"test")]     testGen "(succ *** reverse) (1,\"test\") == (2,\"tset\")" $ (succ *** reverse) (1,"test") == (2,"tset")     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 "typeRep (Proxy :: Proxy Int) == typeOf (1 :: Int)" $ typeRep (Proxy :: Proxy Int) == typeOf (1 :: Int)-    testGen "showVersion (makeVersion [1,2,3]) == \"1.2.3\"" $ showVersion (makeVersion [1,2,3]) == "1.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"@@ -239,38 +296,38 @@     testGen "withTempDir $ \\dir -> do writeFile (dir </> \"foo.txt\") \"\"; withCurrentDirectory dir $ doesFileExist \"foo.txt\"" $ withTempDir $ \dir -> do writeFile (dir </> "foo.txt") ""; withCurrentDirectory dir $ doesFileExist "foo.txt"     testGen "withTempDir $ \\dir -> do writeFile (dir </> \"test.txt\") \"\"; (== [dir </> \"test.txt\"]) <$> listContents dir" $ withTempDir $ \dir -> do writeFile (dir </> "test.txt") ""; (== [dir </> "test.txt"]) <$> listContents dir     let touch = mapM_ $ \x -> createDirectoryIfMissing True (takeDirectory x) >> writeFile x ""-    let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir </>) as; res <- op dir; return $ map (drop (length dir + 1)) res == bs+    let listTest op as bs = withTempDir $ \dir -> do touch $ map (dir </>) as; res <- op dir; pure $ map (drop (length dir + 1)) res == bs     testGen "listTest listContents [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"bar.txt\",\"foo\",\"zoo\"]" $ listTest listContents ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","foo","zoo"]     testGen "listTest listDirectories [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"foo\"]" $ listTest listDirectories ["bar.txt","foo/baz.txt","zoo"] ["foo"]     testGen "listTest listFiles [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"bar.txt\",\"zoo\"]" $ listTest listFiles ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","zoo"]     testGen "listTest listFilesRecursive [\"bar.txt\",\"zoo\",\"foo\" </> \"baz.txt\"] [\"bar.txt\",\"zoo\",\"foo\" </> \"baz.txt\"]" $ listTest listFilesRecursive ["bar.txt","zoo","foo" </> "baz.txt"] ["bar.txt","zoo","foo" </> "baz.txt"]-    testGen "listTest (listFilesInside $ return . not . isPrefixOf \".\" . takeFileName)    [\"bar.txt\",\"foo\" </> \"baz.txt\",\".foo\" </> \"baz2.txt\", \"zoo\"] [\"bar.txt\",\"zoo\",\"foo\" </> \"baz.txt\"]" $ listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName)    ["bar.txt","foo" </> "baz.txt",".foo" </> "baz2.txt", "zoo"] ["bar.txt","zoo","foo" </> "baz.txt"]-    testGen "listTest (listFilesInside $ const $ return False) [\"bar.txt\"] []" $ listTest (listFilesInside $ const $ return False) ["bar.txt"] []+    testGen "listTest (listFilesInside $ pure . not . isPrefixOf \".\" . takeFileName)    [\"bar.txt\",\"foo\" </> \"baz.txt\",\".foo\" </> \"baz2.txt\", \"zoo\"] [\"bar.txt\",\"zoo\",\"foo\" </> \"baz.txt\"]" $ listTest (listFilesInside $ pure . not . isPrefixOf "." . takeFileName)    ["bar.txt","foo" </> "baz.txt",".foo" </> "baz2.txt", "zoo"] ["bar.txt","zoo","foo" </> "baz.txt"]+    testGen "listTest (listFilesInside $ const $ pure False) [\"bar.txt\"] []" $ listTest (listFilesInside $ const $ pure False) ["bar.txt"] []     testGen "isWindows == (os == \"mingw32\")" $ isWindows == (os == "mingw32")     testGen "\\(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \\file -> do writeFile file s; readFile' file" $ \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file     testGen "\\s -> withTempFile $ \\file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file" $ \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file     testGen "\\(ASCIIString s) -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file-    testGen "captureOutput (print 1) == return (\"1\\n\",())" $ captureOutput (print 1) == return ("1\n",())-    testGen "withTempFile doesFileExist == return True" $ withTempFile doesFileExist == return True-    testGen "(doesFileExist =<< withTempFile return) == return False" $ (doesFileExist =<< withTempFile return) == return False-    testGen "withTempFile readFile' == return \"\"" $ withTempFile readFile' == return ""-    testGen "withTempDir doesDirectoryExist == return True" $ withTempDir doesDirectoryExist == return True-    testGen "(doesDirectoryExist =<< withTempDir return) == return False" $ (doesDirectoryExist =<< withTempDir return) == return False-    testGen "withTempDir listFiles == return []" $ withTempDir listFiles == return []+    testGen "captureOutput (print 1) == pure (\"1\\n\",())" $ captureOutput (print 1) == pure ("1\n",())+    testGen "withTempFile doesFileExist == pure True" $ withTempFile doesFileExist == pure True+    testGen "(doesFileExist =<< withTempFile pure) == pure False" $ (doesFileExist =<< withTempFile pure) == pure False+    testGen "withTempFile readFile' == pure \"\"" $ withTempFile readFile' == pure ""+    testGen "withTempDir doesDirectoryExist == pure True" $ withTempDir doesDirectoryExist == pure True+    testGen "(doesDirectoryExist =<< withTempDir pure) == pure False" $ (doesDirectoryExist =<< withTempDir pure) == pure False+    testGen "withTempDir listFiles == pure []" $ withTempDir listFiles == pure []     testGen "fileEq \"does_not_exist1\" \"does_not_exist2\" == undefined" $ erroneousIO $ fileEq "does_not_exist1" "does_not_exist2"     testGen "fileEq \"does_not_exist\" \"does_not_exist\" == undefined" $ erroneousIO $ fileEq "does_not_exist" "does_not_exist"     testGen "withTempFile $ \\f1 -> fileEq \"does_not_exist\" f1 == undefined" $ erroneousIO $ withTempFile $ \f1 -> fileEq "does_not_exist" f1     testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> fileEq f1 f2" $ withTempFile $ \f1 -> withTempFile $ \f2 -> fileEq f1 f2     testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> writeFile f1 \"a\" >> writeFile f2 \"a\" >> fileEq f1 f2" $ withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "a" >> fileEq f1 f2     testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> writeFile f1 \"a\" >> writeFile f2 \"b\" >> notM (fileEq f1 f2)" $ withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "b" >> notM (fileEq f1 f2)-    testGen "fmap (round . fst) (duration $ sleep 1) == return 1" $ fmap (round . fst) (duration $ sleep 1) == return 1-    testGen "timeout (-3) (print 1) == return Nothing" $ timeout (-3) (print 1) == return Nothing+    testGen "fmap (round . fst) (duration $ sleep 1) == pure 1" $ fmap (round . fst) (duration $ sleep 1) == pure 1+    testGen "timeout (-3) (print 1) == pure Nothing" $ timeout (-3) (print 1) == pure Nothing     testGen "timeout 0.1  (print 1) == fmap Just (print 1)" $ timeout 0.1  (print 1) == fmap Just (print 1)-    testGen "do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1" $ do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1-    testGen "timeout 0.1  (sleep 2 >> print 1) == return Nothing" $ timeout 0.1  (sleep 2 >> print 1) == return Nothing+    testGen "do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; pure $ t < 1" $ do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; pure $ t < 1+    testGen "timeout 0.1  (sleep 2 >> print 1) == pure Nothing" $ timeout 0.1  (sleep 2 >> print 1) == pure Nothing     testGen "showDuration 3.435   == \"3.44s\"" $ showDuration 3.435   == "3.44s"     testGen "showDuration 623.8   == \"10m24s\"" $ showDuration 623.8   == "10m24s"     testGen "showDuration 62003.8 == \"17h13m\"" $ showDuration 62003.8 == "17h13m"     testGen "showDuration 1e8     == \"27777h47m\"" $ showDuration 1e8     == "27777h47m"-    testGen "do f <- offsetTime; xs <- replicateM 10 f; return $ xs == sort xs" $ do f <- offsetTime; xs <- replicateM 10 f; return $ xs == sort xs-    testGen "do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.5" $ do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.5+    testGen "do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs" $ do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs+    testGen "do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5" $ do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5

test/TestUtil.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, CPP, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- OK because a test module  module TestUtil@@ -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@@ -22,10 +21,11 @@ import Data.Either.Extra as X import Data.Function as X import Data.IORef.Extra as X-import Data.List.Extra as X-import Data.Monoid as X+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.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@@ -44,7 +44,7 @@ testGen msg prop = testRaw msg $ do     r <- quickCheckResult prop     case r of-        Success{} -> return ()+        Success{} -> pure ()         _ -> errorIO "Test failed"  testRaw :: String -> IO () -> IO ()@@ -65,11 +65,6 @@     | a == b = True     | otherwise = error $ "Not equal!\n" ++ show a ++ "\n" ++ show b -#if __GLASGOW_HASKELL__ < 707-instance Eq ErrorCall where-    ErrorCall x == ErrorCall y = x == y-#endif- runTests :: IO () -> IO () runTests t = do     -- ensure that capturing output is robust@@ -88,9 +83,9 @@ -- 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-        if a == b then return True else+        a <- captureOutput $ try_ a+        b <- captureOutput $ try_ b+        if a == b then pure True else             error $ show ("IO values not equal", a, b)  instance Show (IO a) where@@ -99,10 +94,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