diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,92 +1,210 @@ -Changelog for Extra +Changelog for Extra (* = breaking change) -1.5.3 +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 + #39, add curry3/uncurry3 +1.6.11, released 2018-09-18 + #38, make escapeHTML replace ' with ' +1.6.10, released 2018-09-04 + #37, make a duration/sleep test more robust (wider bounds) +1.6.9, released 2018-07-12 + Add loop, the non-monadic version of loopM + #36, add whenMaybe and whenMaybeM +1.6.8, released 2018-05-24 + Add notNull + Add listDirectories +1.6.7, released 2018-05-23 + #35, add fold1M and fold1M_ + #34, lots of documentation typos +1.6.6, released 2018-04-16 + Add escapeJSON and unescapeJSON + Add escapeHTML and unescapeHTML +1.6.5, released 2018-03-24 + #33, improve error messages on test suite failures +1.6.4, released 2018-02-23 + Add dropPrefix and dropSuffix +1.6.3, released 2018-01-26 + Add maximumOn and minimumOn + #31, add nubSort, nubSortBy and nubSortOn +1.6.2, released 2017-12-07 + Mark the partial functions with Partial + Add Partial constraint +1.6.1, released 2017-11-30 + Add newTempFileWithin and newTempDirWithin + Mark the Extra module as deprecated, used for documentation only +1.6, released 2017-06-16 + #23, delete subtractTime + Require QuickCheck-2.10 +1.5.3, released 2017-06-12 Add readMaybe, readEither -1.5.2 +1.5.2, released 2017-04-04 Add errorWithoutStackTrace to Control.Exception.Extra -1.5.1 +1.5.1, released 2016-10-25 #25, add zipFrom and zipWithFrom #24, add eitherToMaybe and maybeToEither Add fromLeft' and fromRight' -1.5 +1.5, released 2016-07-21 Change fromLeft/fromRight signatures to follow the base libraries -1.4.12 +1.4.12, released 2016-07-18 Add writeVar -1.4.11 +1.4.11, released 2016-07-15 Require QuickCheck 2.9 #23, deprecate offsetTimeIncrease and subtract #22, improve offsetTime to give reliable measurements Depend on the clock library -1.4.10 +1.4.10, released 2016-06-15 Add Data.Typeable.Extra containing typeRep, Proxy, (:~:) -1.4.9 +1.4.9, released 2016-06-01 Add line1 -1.4.8 +1.4.8, released 2016-05-26 Add displayException -1.4.7 +1.4.7, released 2016-05-22 #21, add concatForM -1.4.6 +1.4.6, released 2016-05-11 #11, add maybeM and eitherM -1.4.5 +1.4.5, released 2016-04-29 #17, change fileEq on files that do not exist to be an error -1.4.4 +1.4.4, released 2016-04-29 #14, add mconcatMap and mconcatMapM #16, add fileEq #15, add isMac -1.4.3 +1.4.3, released 2016-01-07 Add Data.Version.Extra -1.4.2 +1.4.2, released 2015-09-14 Make concatMapM/mapMaybeM faster -1.4.1 +1.4.1, released 2015-08-04 Make temp file functions workaround GHC bug #10731 Add retryBool -1.4 +1.4, released 2015-07-23 Add stripInfix and stripInfixEnd -1.3.1 +1.3.1, released 2015-07-17 #9, support directory-1.2.3 -1.3 +1.3, released 2015-06-20 Add whenJustM Add errorIO -1.2 +1.2, released 2015-05-18 Add onceFork Make once async exception safe Fix a deadlock in once when two people request in parallel Fix a missing hClose in captureOutput -1.1 +1.1, released 2015-02-17 #7, add nubOrd, nubOrdOn, nubOrdBy #6, add groupSortOn and groupSortBy #5, add splitAtEnd -1.0.1 +1.0.1, released 2015-01-09 Make listFilesAvoid drop trailing path separators before testing #3, add a constraint base >= 4.4 -1.0 +1.0, released 2014-11-27 No changes -0.8 +0.8, released 2014-11-12 Fix a bug in writeFileEncoding/writeFileUTF8 -0.7 +0.7, released 2014-11-03 Fix for missing case in withNumCapabilities -0.6 +0.6, released 2014-10-31 Ensure barrier is thread-safe Make subsequent signalBarrier calls throw an exception Add timeout function Make sure sleep never wraps round an Int -0.5.1 +0.5.1, released 2014-10-28 Use uncons from GHC 7.9 and above -0.5 +0.5, released 2014-10-28 Use the sortOn from GHC 7.9 and above Remove getProcessorCount Remove getDirectoryContentsRecursive in favour of listFilesRecursive Change the signature for newTempFile/newTempDir Add a once function -0.4 +0.4, released 2014-10-23 Remove all but the extractors on triples Remove groupSortOn Remove dropAround -0.3.2 +0.3.2, released 2014-10-21 Remove use of ===, allows older QuickCheck versions -0.3.1 +0.3.1, released 2014-10-20 Fix a bug in breakEnd/spanEnd -0.3 +0.3, released 2014-10-18 Rename showTime to showDuration Add stringException Eliminate rep/reps, use replace instead @@ -99,11 +217,11 @@ Add createDirectoryPrivate Rename strip* to trim* Generalise showException -0.2 +0.2, released 2014-10-07 Redo the cons/uncons functions Add withTempDir Rename withTemporaryFile to withTempFile Change trim to strip (follow text naming convention) Ensure operators get exported -0.1 +0.1, released 2014-10-06 Initial version, still unstable diff --git a/Generate.hs b/Generate.hs --- a/Generate.hs +++ b/Generate.hs @@ -1,10 +1,15 @@ -- 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 import Data.List.Extra import System.IO.Extra +import Control.Exception import Control.Monad.Extra import System.FilePath import System.Directory @@ -18,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" @@ -33,21 +38,24 @@ ,"--" ,"-- Most users should import the specific modules (e.g. @\"Data.List.Extra\"@), which" ,"-- also reexport their non-@Extra@ modules (e.g. @\"Data.List\"@)." - ,"module Extra("] ++ + ,"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"] ++ @@ -60,10 +68,34 @@ writeFileBinaryChanged :: FilePath -> String -> IO () writeFileBinaryChanged file x = do - old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (return Nothing) + evaluate $ length x -- ensure we don't write out files with _|_ in them + 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)) && diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2014-2017. +Copyright Neil Mitchell 2014-2025. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,34 +1,27 @@ -# 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/lts?label=Stackage)](https://www.stackage.org/package/extra) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/extra.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/extra) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/extra.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. - ## Which functions? When producing a library of extra functions I have been guided by a few principles. I encourage others with small useful utility functions contribute them here, perhaps as a temporary stop before proposing they join the standard libraries. * 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 -The following GHC versions correspond to the following base library versions: +A mapping between `base` versions and GHC compiler versions can be found [here](https://wiki.haskell.org/Base_package#Versions). -* base 4.9 == GHC 8.0 -* base 4.8 == GHC 7.10 -* base 4.7 == GHC 7.8 -* base 4.6 == GHC 7.6 -* base 4.5 == GHC 7.4 -* base 4.4 == GHC 7.2 +## Contributing -A more complete list can be found [here](https://wiki.haskell.org/Base_package#Versions). +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. diff --git a/extra.cabal b/extra.cabal --- a/extra.cabal +++ b/extra.cabal @@ -1,13 +1,13 @@ -cabal-version: >= 1.18 +cabal-version: 1.18 build-type: Simple name: extra -version: 1.5.3 +version: 1.8.1 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2014-2017 +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.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, @@ -40,14 +40,19 @@ if !os(windows) build-depends: unix + other-modules: + Partial exposed-modules: Extra 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 @@ -68,9 +73,8 @@ directory, filepath, extra, - clock >= 0.7, - time, - QuickCheck >= 2.9 + QuickCheck >= 2.10, + quickcheck-instances >= 0.3.17 if !os(windows) build-depends: unix hs-source-dirs: test diff --git a/src/Control/Concurrent/Extra.hs b/src/Control/Concurrent/Extra.hs --- a/src/Control/Concurrent/Extra.hs +++ b/src/Control/Concurrent/Extra.hs @@ -1,25 +1,28 @@ -{-# LANGUAGE CPP, TupleSections #-} -{-# 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 --- +-- -- for examples and justification. -- -- If you need greater control of exceptions and threads --- see the package. +-- see the package. -- If you need elaborate relationships between threads --- see the package. +-- see the 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,25 +81,25 @@ onceFork act = do bar <- newBarrier forkFinally act $ signalBarrier bar - return $ either throwIO return =<< waitBarrier bar + pure $ eitherM throwIO pure $ waitBarrier bar --------------------------------------------------------------------- -- LOCK --- | Like an MVar, but has no value. --- Used to guarantees single-threaded access, typically to some system resource. +-- | Like an 'MVar', but has no value. +-- Used to guarantee single-threaded access, typically to some system resource. -- As an example: -- -- @ -- lock <- 'newLock' --- let output = 'withLock' . putStrLn +-- let output = 'withLock' lock . putStrLn -- forkIO $ do ...; output \"hello\" -- forkIO $ do ...; output \"world\" -- @ -- -- Here we are creating a lock to ensure that when writing output our messages --- do not get interleaved. This use of MVar never blocks on a put. It is permissible, +-- do not get interleaved. This use of 'MVar' never blocks on a put. It is permissible, -- but rare, that a withLock contains a withLock inside it - but if so, -- watch out for deadlocks. @@ -149,29 +120,29 @@ 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) --------------------------------------------------------------------- -- VAR --- | Like an MVar, but must always be full. --- Used to on a mutable variable in a thread-safe way. +-- | Like an 'MVar', but must always be full. +-- Used to operate on a mutable variable in a thread-safe way. -- As an example: -- -- @ -- hits <- 'newVar' 0 -- forkIO $ do ...; 'modifyVar_' hits (+1); ... -- i <- 'readVar' hits --- print ("HITS",i) +-- print (\"HITS\",i) -- @ -- -- Here we have a variable which we modify atomically, so modifications are --- not interleaved. This use of MVar never blocks on a put. No modifyVar +-- not interleaved. This use of 'MVar' never blocks on a put. No modifyVar -- operation should ever block, and they should always complete in a reasonable --- timeframe. A Var should not be used to protect some external resource, only --- the variable contained within. Information from a readVar should not be subsequently --- inserted back into the Var. +-- timeframe. A 'Var' should not be used to protect some external resource, only +-- the variable contained within. Information from a 'readVar' should not be subsequently +-- inserted back into the 'Var'. newtype Var a = Var (MVar a) -- | Create a new 'Var' with a value. @@ -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 :: 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 :: Partial => Barrier a -> a -> IO () +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 diff --git a/src/Control/Exception/Extra.hs b/src/Control/Exception/Extra.hs --- a/src/Control/Exception/Extra.hs +++ b/src/Control/Exception/Extra.hs @@ -1,15 +1,19 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE ScopedTypeVariables, CPP, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | 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 +-- 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_, @@ -17,25 +21,30 @@ catchBool, handleBool, tryBool ) where +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Stack +#endif + import Control.Exception import Control.Monad import Data.List.Extra import Data.Functor +import Partial import Prelude -- | Fully evaluate an input String. If the String contains embedded exceptions it will produce @\@. -- --- > stringException "test" == return "test" --- > stringException ("test" ++ undefined) == return "test" --- > stringException ("test" ++ undefined ++ "hello") == return "test" --- > stringException ['t','e','s','t',undefined] == return "test" +-- > stringException "test" == pure "test" +-- > stringException ("test" ++ undefined) == pure "test" +-- > stringException ("test" ++ undefined ++ "hello") == pure "test" +-- > stringException ['t','e','s','t',undefined] == pure "test" stringException :: String -> IO String stringException x = do r <- try_ $ evaluate $ list [] (\x xs -> x `seq` x:xs) x case r of - Left e -> return "" - Right [] -> return [] + Left e -> pure "" + Right [] -> pure [] Right (x:xs) -> (x:) <$> stringException xs @@ -47,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 @@ -64,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")) -errorIO :: String -> IO a -errorIO = throwIO . ErrorCall +-- > catch (errorIO "Hello") (\(ErrorCall x) -> pure x) == pure "Hello" +-- > seq (errorIO "foo") (print 1) == print 1 +{-# NOINLINE errorIO #-} -- otherwise GHC 8.4.1 seems to get upset +errorIO :: Partial => String -> IO a +errorIO x = withFrozenCallStack $ evaluate $ error x +#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. -- @@ -95,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', @@ -127,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 diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs --- a/src/Control/Monad/Extra.hs +++ b/src/Control/Monad/Extra.hs @@ -1,22 +1,28 @@ +{-# LANGUAGE ConstraintKinds #-} -- | 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 . +-- If you need a wider selection of monad loops and list generalisations, +-- see . module Control.Monad.Extra( module Control.Monad, whenJust, whenJustM, + pureIf, + whenMaybe, whenMaybeM, unit, - maybeM, eitherM, + maybeM, fromMaybeM, eitherM, + guarded, guardedA, -- * Loops - loopM, whileM, + loop, loopM, whileM, whileJustM, untilJustM, -- * Lists partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, + fold1M, fold1M_, -- * Booleans whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM ) where import Control.Monad +import Control.Exception.Extra import Data.Maybe import Control.Applicative import Data.Monoid @@ -25,78 +31,167 @@ -- 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 () -whenJustM mg f = maybe (return ()) f =<< mg +-- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative +whenJustM mg f = maybeM (pure ()) f mg +-- | Return either a `pure` value if a condition is `True`, otherwise `empty`. +-- +-- > pureIf @Maybe True 5 == Just 5 +-- > pureIf @Maybe False 5 == Nothing +-- > pureIf @[] True 5 == [5] +-- > pureIf @[] False 5 == [] +{-# INLINABLE pureIf #-} +pureIf :: (Alternative m) => Bool -> a -> m a +pureIf b a = if b then pure a else empty + +-- | Like 'when', but return either 'Nothing' if the predicate was 'False', +-- or 'Just' with the result of the computation. +-- +-- > whenMaybe True (print 1) == fmap Just (print 1) +-- > whenMaybe False (print 1) == pure Nothing +{-# INLINABLE whenMaybe #-} +whenMaybe :: Applicative m => Bool -> m a -> m (Maybe a) +whenMaybe b x = if b then Just <$> x else pure Nothing + +-- | Like 'whenMaybe', but where the test can be monadic. +{-# INLINABLE whenMaybeM #-} +whenMaybeM :: Monad m => m Bool -> m a -> m (Maybe a) +-- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative +whenMaybeM mb x = do + b <- mb + if b then liftM Just x else pure Nothing + -- | The identity function which requires the inner argument to be @()@. Useful for functions -- with overloaded return types. -- -- > \(x :: Maybe ()) -> unit x == x +{-# INLINABLE unit #-} unit :: m () -> m () unit = id -- | Monadic generalisation of 'maybe'. +{-# INLINABLE maybeM #-} maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM n j x = maybe n j =<< x +-- | Monadic generalisation of 'fromMaybe'. +{-# INLINABLE fromMaybeM #-} +fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a +fromMaybeM n x = maybeM n pure x + + -- | Monadic generalisation of 'either'. +{-# INLINABLE eitherM #-} eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c eitherM l r x = either l r =<< x +-- | Either lifts a value into an alternative context or gives a +-- minimal value depending on a predicate. Works with 'Alternative's. +-- +-- > guarded even 2 == [2] +-- > guarded odd 2 == Nothing +-- > guarded (not.null) "My Name" == Just "My Name" +{-# INLINABLE guarded #-} +guarded :: Alternative m => (a -> Bool) -> a -> m a +guarded pred x = if pred x then pure x else empty + +-- | A variant of `guarded` using 'Functor'-wrapped values. +-- +-- > guardedA (return . even) 42 == Just [42] +-- > guardedA (return . odd) 42 == Just [] +-- > guardedA (const Nothing) 42 == (Nothing :: Maybe [Int]) +{-# INLINABLE guardedA #-} +guardedA :: (Functor f, Alternative m) => (a -> f Bool) -> a -> f (m a) +guardedA pred x = fmap inner (pred x) + where inner b = if b then pure x else empty + +-- | A variant of 'foldM' that has no base case, and thus may only be applied to non-empty lists. +-- +-- > fold1M (\x y -> Just x) [] == undefined +-- > fold1M (\x y -> Just $ x + y) [1, 2, 3] == Just 6 +{-# INLINABLE fold1M #-} +fold1M :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m a +fold1M f (x:xs) = foldM f x xs +fold1M f xs = error "fold1M: empty list" + +-- | Like 'fold1M' but discards the result. +{-# INLINABLE fold1M_ #-} +fold1M_ :: (Partial, Monad m) => (a -> a -> m a) -> [a] -> m () +fold1M_ f xs = fold1M f xs >> pure () + + -- Data.List for Monad -- | A version of 'partition' that works with a monadic predicate. -- -- > 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 -- | A looping operation, where the predicate returns 'Left' as a seed for the next loop -- 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 + Right v -> v + +-- | 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: -- @@ -106,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 @@ -136,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 @@ -146,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 @@ -180,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 @@ -190,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) diff --git a/src/Data/Either/Extra.hs b/src/Data/Either/Extra.hs --- a/src/Data/Either/Extra.hs +++ b/src/Data/Either/Extra.hs @@ -1,17 +1,22 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | 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 +-- . 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 +import Partial #if __GLASGOW_HASKELL__ < 801 @@ -41,7 +46,7 @@ -- -- > \x -> fromLeft' (Left x) == x -- > \x -> fromLeft' (Right x) == undefined -fromLeft' :: Either l r -> l +fromLeft' :: Partial => Either l r -> l fromLeft' (Left x) = x fromLeft' _ = error "fromLeft', given a Right" @@ -51,23 +56,11 @@ -- -- > \x -> fromRight' (Right x) == x -- > \x -> fromRight' (Left x) == undefined -fromRight' :: Either l r -> r +fromRight' :: Partial => Either l r -> r fromRight' (Right x) = x 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. -- @@ -92,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 diff --git a/src/Data/Foldable/Extra.hs b/src/Data/Foldable/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Foldable/Extra.hs @@ -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) diff --git a/src/Data/IORef/Extra.hs b/src/Data/IORef/Extra.hs --- a/src/Data/IORef/Extra.hs +++ b/src/Data/IORef/Extra.hs @@ -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, ()) diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -1,46 +1,64 @@ -{-# LANGUAGE CPP, TupleSections, BangPatterns #-} +{-# 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 --- package. +-- package. module Data.List.Extra( module Data.List, -- * String operations lower, upper, trim, trimStart, trimEnd, word1, line1, - -- * Splitting + escapeHTML, escapeJSON, + 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 - 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, - disjoint, allSame, anySame, - repeatedly, for, firstJust, + nubOn, groupOn, groupOnKey, + nubSort, nubSortBy, nubSortOn, + maximumOn, minimumOn, + sum', product', + sumOn', productOn', + disjoint, disjointOrd, disjointOrdBy, allSame, anySame, + repeatedly, repeatedlyNE, firstJust, concatUnzip, concatUnzip3, - zipFrom, zipWithFrom, + zipFrom, zipWithFrom, zipWithLongest, replace, merge, mergeBy, ) where +import Partial import Data.List import Data.Maybe import Data.Function import Data.Char import Data.Tuple.Extra 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 @@ -49,13 +67,17 @@ repeatedly f as = b : repeatedly f as' where (b, as') = f as - --- | Flipped version of 'map'. +-- | Apply some operation repeatedly, producing an element of output +-- and the remainder of the list. -- --- > for [1,2,3] (+1) == [2,3,4] -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 @@ -63,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 @@ -89,6 +138,49 @@ 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 +-- > notNull [1] == True +-- > \xs -> notNull xs == not (null xs) +notNull :: [a] -> Bool +notNull = not . null + -- | Non-recursive transform over a list, like 'maybe'. -- -- > list 1 (\v _ -> v - 2) [5,6,7] == 3 @@ -98,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') @@ -119,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 '(:)'. -- @@ -135,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" @@ -143,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 @@ -156,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 _ _ = [] @@ -169,35 +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 False [1..3] == [(False,1),(True, 2)] zipFrom :: Enum a => a -> [b] -> [(a, b)] zipFrom = zipWithFrom (,) -- | 'zipFrom' generalised to any combining operation. +-- Truncates the output if the enumeration runs out. -- -- > \i xs -> zipWithFrom (,) i xs == zipFrom i xs zipWithFrom :: 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 +-- 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'. -- @@ -247,7 +341,7 @@ -- | Split the first word off a string. Useful for when starting to parse the beginning --- of a string, but you want to accurately perserve whitespace in the rest of the string. +-- of a string, but you want to accurately preserve whitespace in the rest of the string. -- -- > word1 "" == ("", "") -- > word1 "keyword rest of string" == ("keyword","rest of string") @@ -255,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. -- @@ -267,41 +361,143 @@ line1 :: String -> (String, String) line1 = second drop1 . break (== '\n') +-- | Escape a string such that it can be inserted into an HTML document or @\"@ attribute +-- without any special interpretation. This requires escaping the @<@, @>@, @&@ and @\"@ characters. +-- Note that it will escape @\"@ and @\'@ even though that is not required in an HTML body (but is not harmful). +-- +-- > escapeHTML "this is a test" == "this is a test" +-- > escapeHTML "\"g&t\"" == "<b>"g&t"</n>" +-- > escapeHTML "t'was another test" == "t'was another test" +escapeHTML :: String -> String +escapeHTML = concatMap f + where + f '>' = ">" + f '<' = "<" + f '&' = "&" + f '\"' = """ + f '\'' = "'" + f x = [x] -#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. +-- | Invert of 'escapeHTML' (does not do general HTML unescaping) -- --- > 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 +-- > \xs -> unescapeHTML (escapeHTML xs) == xs +unescapeHTML :: String -> String +unescapeHTML ('&':xs) + | Just xs <- stripPrefix "lt;" xs = '<' : unescapeHTML xs + | Just xs <- stripPrefix "gt;" xs = '>' : unescapeHTML xs + | Just xs <- stripPrefix "amp;" xs = '&' : unescapeHTML xs + | Just xs <- stripPrefix "quot;" xs = '\"' : unescapeHTML xs + | Just xs <- stripPrefix "#39;" xs = '\'' : unescapeHTML xs +unescapeHTML (x:xs) = x : unescapeHTML xs +unescapeHTML [] = [] + +-- | Escape a string so it can form part of a JSON literal. +-- This requires escaping the special whitespace and control characters. Additionally, +-- Note that it does /not/ add quote characters around the string. +-- +-- > escapeJSON "this is a test" == "this is a test" +-- > escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\" +-- > escapeJSON "\ESC[0mHello" == "\\u001b[0mHello" +escapeJSON :: String -> String +escapeJSON x = concatMap f x + where f '\"' = "\\\"" + f '\\' = "\\\\" + -- the spaces are technically optional, but we include them so the JSON is readable + f '\b' = "\\b" + f '\f' = "\\f" + f '\n' = "\\n" + f '\r' = "\\r" + f '\t' = "\\t" + f x | isControl x = "\\u" ++ takeEnd 4 ("0000" ++ showHex (ord x) "") + f x = [x] + +-- | General JSON unescaping, inversion of 'escapeJSON' and all other JSON escapes. +-- +-- > \xs -> unescapeJSON (escapeJSON xs) == xs +unescapeJSON :: String -> String +unescapeJSON ('\\':x:xs) + | x == '\"' = '\"' : unescapeJSON xs + | x == '\\' = '\\' : unescapeJSON xs + | x == '/' = '/' : unescapeJSON xs + | x == 'b' = '\b' : unescapeJSON xs + | x == 'f' = '\f' : unescapeJSON xs + | x == 'n' = '\n' : unescapeJSON xs + | x == 'r' = '\r' : unescapeJSON xs + | x == 't' = '\t' : unescapeJSON xs + | x == 'u', let (a,b) = splitAt 4 xs, length a == 4, [(i, "")] <- readHex a = chr i : unescapeJSON b +unescapeJSON (x:xs) = x : unescapeJSON xs +unescapeJSON [] = [] + + -- | 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. +-- 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. +-- 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'. -- -- > groupSort [(1,'t'),(3,'t'),(2,'e'),(2,'s')] == [(1,"t"),(2,"es"),(3,"t")] -- > \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. -- @@ -316,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" @@ -333,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 "" "x" "Hello" == "xHxexlxlxox" +-- > replace "" "x" "" == "x" +-- > \xs ys -> replace xs xs ys == ys replace :: Eq a => [a] -> [a] -> [a] -> [a] -replace [] _ _ = error "Extra.replace, first argument cannot be empty" +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 [] = [] @@ -413,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 @@ -425,7 +659,7 @@ -- The first element of the returned tuple -- is the prefix of @haystack@ before @needle@ is matched. The second -- is the remainder of @haystack@, starting with the match. --- If you want the remainder /without/ the patch, use 'stripInfix'. +-- If you want the remainder /without/ the match, use 'stripInfix'. -- -- > breakOn "::" "a::b::c" == ("a", "::b::c") -- > breakOn "/" "foobar" == ("foobar", "") @@ -457,7 +691,7 @@ -- > splitOn "x" "" == [""] -- > \s x -> s /= "" ==> intercalate s (splitOn s x) == x -- > \c x -> splitOn [c] x == split (==c) x -splitOn :: Eq a => [a] -> [a] -> [[a]] +splitOn :: (Partial, Eq a) => [a] -> [a] -> [[a]] splitOn [] _ = error "splitOn, needle may not be empty" splitOn _ [] = [[]] splitOn needle haystack = a : if null b then [] else splitOn needle $ drop (length needle) b @@ -479,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 @@ -501,9 +729,28 @@ dropWhileEnd' :: (a -> Bool) -> [a] -> [a] dropWhileEnd' p = foldr (\x xs -> if null xs && p x then [] else x : xs) [] --- | Return the prefix of the second string if its suffix --- matches the entire first string. + +-- | Drops the given prefix from a list. +-- It returns the original sequence if the sequence doesn't start with the given prefix. -- +-- > dropPrefix "Mr. " "Mr. Men" == "Men" +-- > dropPrefix "Mr. " "Dr. Men" == "Dr. Men" +dropPrefix :: Eq a => [a] -> [a] -> [a] +dropPrefix a b = fromMaybe b $ stripPrefix a b + + +-- | Drops the given suffix from a list. +-- It returns the original sequence if the sequence doesn't end with the given suffix. +-- +-- > dropSuffix "!" "Hello World!" == "Hello World" +-- > dropSuffix "!" "Hello World!!" == "Hello World!" +-- > dropSuffix "!" "Hello World." == "Hello World." +dropSuffix :: Eq a => [a] -> [a] -> [a] +dropSuffix a b = fromMaybe b $ stripSuffix a b + +-- | Return the prefix of the second list if its suffix +-- matches the entire first list. +-- -- Examples: -- -- > stripSuffix "bar" "foobar" == Just "foo" @@ -541,11 +788,35 @@ -- > chunksOf 3 "mytest" == ["myt","est"] -- > chunksOf 8 "" == [] -- > chunksOf 0 "test" == undefined -chunksOf :: Int -> [a] -> [[a]] +chunksOf :: Partial => Int -> [a] -> [[a]] chunksOf i xs | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i chunksOf i xs = repeatedly (splitAt i) xs +-- | /O(n log n)/. The 'nubSort' function sorts and removes duplicate elements from a list. +-- In particular, it keeps only the first occurrence of each element. +-- +-- > nubSort "this is a test" == " aehist" +-- > \xs -> nubSort xs == nub (sort xs) +nubSort :: Ord a => [a] -> [a] +nubSort = nubSortBy compare + +-- | A version of 'nubSort' which operates on a portion of the value. +-- +-- > nubSortOn length ["a","test","of","this"] == ["a","of","test"] +nubSortOn :: Ord b => (a -> b) -> [a] -> [a] +nubSortOn f = nubSortBy (compare `on` f) + +-- | A version of 'nubSort' with a custom predicate. +-- +-- > nubSortBy (compare `on` length) ["a","test","of","this"] == ["a","of","test"] +nubSortBy :: (a -> a -> Ordering) -> [a] -> [a] +nubSortBy cmp = f . sortBy cmp + where f (x1:x2:xs) | cmp x1 x2 == EQ = f (x1:xs) + 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 @@ -556,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. -- @@ -563,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"] @@ -571,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 diff --git a/src/Data/List/NonEmpty/Extra.hs b/src/Data/List/NonEmpty/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/NonEmpty/Extra.hs @@ -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 diff --git a/src/Data/Monoid/Extra.hs b/src/Data/Monoid/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Monoid/Extra.hs @@ -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 diff --git a/src/Data/Tuple/Extra.hs b/src/Data/Tuple/Extra.hs --- a/src/Data/Tuple/Extra.hs +++ b/src/Data/Tuple/Extra.hs @@ -1,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,12 @@ first, second, (***), (&&&), -- * More pair operations dupe, both, - -- * Extract from a triple - fst3, snd3, thd3 + -- * Monadic versions + firstM, secondM, + -- * Operations on triple + fst3, snd3, thd3, + first3, second3, third3, + curry3, uncurry3 ) where import Data.Tuple @@ -29,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.***'. -- @@ -53,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 @@ -66,3 +83,30 @@ -- | Extract the final element of a triple. thd3 :: (a,b,c) -> c thd3 (a,b,c) = c + +-- | Converts an uncurried function to a curried function. +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +curry3 f a b c = f (a,b,c) + +-- | 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) diff --git a/src/Data/Typeable/Extra.hs b/src/Data/Typeable/Extra.hs --- a/src/Data/Typeable/Extra.hs +++ b/src/Data/Typeable/Extra.hs @@ -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 diff --git a/src/Data/Version/Extra.hs b/src/Data/Version/Extra.hs --- a/src/Data/Version/Extra.hs +++ b/src/Data/Version/Extra.hs @@ -1,33 +1,23 @@ -{-# LANGUAGE CPP #-} -{-# 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 import Data.Version 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. -- -- > \x -> readVersion (showVersion x) == x -- > readVersion "hello" == undefined -readVersion :: String -> Version +readVersion :: Partial => String -> Version readVersion s = case [ x | (x,"") <- readP_to_S parseVersion $ trimEnd s] of [x] -> x diff --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -5,58 +5,55 @@ -- -- Most users should import the specific modules (e.g. @"Data.List.Extra"@), which -- also reexport their non-@Extra@ modules (e.g. @"Data.List"@). -module Extra( +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"@. - 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, unit, maybeM, eitherM, loopM, whileM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, 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, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, 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, - -- * 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, listFiles, listFilesInside, listFilesRecursive, - -- * System.Environment.Extra - -- | Extra functions available in @"System.Environment.Extra"@. - getExecutablePath, lookupEnv, + withCurrentDirectory, createDirectoryPrivate, listContents, listDirectories, listFiles, listFilesInside, listFilesRecursive, -- * System.Info.Extra -- | Extra functions available in @"System.Info.Extra"@. isWindows, isMac, -- * System.IO.Extra -- | Extra functions available in @"System.IO.Extra"@. - captureOutput, withBuffering, readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, fileEq, + captureOutput, withBuffering, readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, newTempFileWithin, newTempDirWithin, fileEq, -- * System.Process.Extra -- | Extra functions available in @"System.Process.Extra"@. system_, systemOutput, systemOutput_, -- * System.Time.Extra -- | Extra functions available in @"System.Time.Extra"@. - Seconds, sleep, timeout, subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration, - -- * Text.Read.Extra - -- | Extra functions available in @"Text.Read.Extra"@. - readEither, readMaybe, + Seconds, sleep, timeout, showDuration, offsetTime, offsetTimeIncrease, duration, ) 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 diff --git a/src/Numeric/Extra.hs b/src/Numeric/Extra.hs --- a/src/Numeric/Extra.hs +++ b/src/Numeric/Extra.hs @@ -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 - - diff --git a/src/Partial.hs b/src/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Partial.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE CPP #-} + +-- | ConstraintKind synonym for marking partial functions +module Partial(Partial) where +-- Originally taken from the @safe@ package + +-- GHC has changed its opinion on the location a few times +-- v0: GHC 7.4.1, has ConstraintKinds +-- v1: GHC 7.10.2, base 4.8.1.0 = CallStack +-- v2: GHC 8.0.1, base 4.9.0.0 = HasCallStack + +-- We never support GHC 7.10.2 style because that requires users to pass the FlexibleContexts +-- extension + +#if __GLASGOW_HASKELL__ >= 800 +import GHC.Stack +#else +import GHC.Exts +#endif + +-- | A constraint which documents that a function is partial, and on GHC 8.0 +-- and above produces a stack trace on failure. For example: +-- +-- @ +-- myHead :: 'Partial' => [a] -> a +-- myHead [] = error \"bad\" +-- myHead (x:xs) = x +-- @ +-- +-- When using 'Partial' with GHC 7.8 or below you need to enable the +-- language feature @ConstraintKinds@, e.g. @{-\# LANGUAGE ConstraintKinds \#-}@ +-- at the top of the file. +#if __GLASGOW_HASKELL__ >= 800 +type Partial = HasCallStack +#else +type Partial = (() :: Constraint) +#endif diff --git a/src/System/Directory/Extra.hs b/src/System/Directory/Extra.hs --- a/src/System/Directory/Extra.hs +++ b/src/System/Directory/Extra.hs @@ -17,7 +17,7 @@ withCurrentDirectory, #endif createDirectoryPrivate, - listContents, listFiles, listFilesInside, listFilesRecursive + listContents, listDirectories, listFiles, listFilesInside, listFilesRecursive ) where import System.Directory @@ -52,13 +52,22 @@ -- -- > 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. +-- Each directory will be prefixed by the query directory. +-- +-- > listTest listDirectories ["bar.txt","foo/baz.txt","zoo"] ["foo"] +listDirectories :: FilePath -> IO [FilePath] +listDirectories dir = filterM doesDirectoryExist =<< listContents dir + + -- | Like 'listContents', but only returns the files in a directory, not other directories. -- Each file will be prefixed by the query directory. -- @@ -72,21 +81,21 @@ -- -- > listTest listFilesRecursive ["bar.txt","zoo","foo" "baz.txt"] ["bar.txt","zoo","foo" "baz.txt"] listFilesRecursive :: FilePath -> IO [FilePath] -listFilesRecursive = listFilesInside (const $ return True) +listFilesRecursive = listFilesInside (const $ pure True) -- | Like 'listFilesRecursive', but with a predicate to decide where to recurse into. -- Typically directories starting with @.@ would be ignored. The initial argument directory -- will have the test applied to it. -- --- > listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName) +-- > listTest (listFilesInside $ pure . not . isPrefixOf "." . takeFileName) -- > ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] --- > listTest (listFilesInside $ const $ return False) ["bar.txt"] [] +-- > listTest (listFilesInside $ const $ pure False) ["bar.txt"] [] listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] -listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (return []) $ do +listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir rest <- concatMapM (listFilesInside test) dirs - return $ files ++ rest + pure $ files ++ rest -- | Create a directory with permissions so that only the current user can view it. diff --git a/src/System/Environment/Extra.hs b/src/System/Environment/Extra.hs --- a/src/System/Environment/Extra.hs +++ b/src/System/Environment/Extra.hs @@ -1,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 diff --git a/src/System/IO/Extra.hs b/src/System/IO/Extra.hs --- a/src/System/IO/Extra.hs +++ b/src/System/IO/Extra.hs @@ -1,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 package. +-- the package. module System.IO.Extra( module System.IO, captureOutput, @@ -16,6 +17,7 @@ writeFileEncoding, writeFileUTF8, writeFileBinary, -- * Temporary files withTempFile, withTempDir, newTempFile, newTempDir, + newTempFileWithin, newTempDirWithin, -- * File comparison fileEq, ) where @@ -60,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. @@ -75,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 @@ -103,7 +110,7 @@ -- | Write a binary file. -- --- > \s -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file +-- > \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file writeFileBinary :: FilePath -> String -> IO () writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x @@ -111,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 @@ -119,7 +126,7 @@ hClose h act out <- readFile' file - return (out, res) + pure (out, res) where clone out h act = do buf <- hGetBuffering out @@ -158,17 +165,20 @@ -- temporary file. Most users should use 'withTempFile' which -- combines these operations. newTempFile :: IO (FilePath, IO ()) -newTempFile = do +newTempFile = newTempFileWithin =<< getTemporaryDirectory + +-- | Like 'newTempFile' but using a custom temporary directory. +newTempFileWithin :: FilePath -> IO (FilePath, IO ()) +newTempFileWithin tmpdir = do file <- create del <- once $ ignore $ removeFile file - return (file, del) + pure (file, del) where create = do - tmpdir <- getTemporaryDirectory 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 @@ -176,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 @@ -189,26 +199,29 @@ -- temporary directory. Most users should use 'withTempDir' which -- combines these operations. newTempDir :: IO (FilePath, IO ()) -newTempDir = do - tmpdir <- getTemporaryDirectory +newTempDir = newTempDirWithin =<< getTemporaryDirectory + +-- | Like 'newTempDir' but using a custom temporary directory. +newTempDirWithin :: FilePath -> IO (FilePath, IO ()) +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 @@ -221,15 +234,15 @@ foreign import ccall unsafe "string.h memcmp" memcmp :: Ptr CUChar -> Ptr CUChar -> CSize -> IO CInt --- | Returs 'True' when the contents of both files is the same. +-- | Returns 'True' when the contents of both files is the same. sameContent :: Handle -> Handle -> IO Bool sameContent h1 h2 = sameSize h1 h2 &&^ withb (\b1 -> withb $ \b2 -> eq b1 b2) where eq b1 b2 = do r1 <- hGetBuf h1 b1 bufsz r2 <- hGetBuf h2 b2 bufsz if r1 == 0 - then return $ r2 == 0 - else return (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2 + then pure $ r2 == 0 + else pure (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2 bufeq b1 b2 s = (==0) <$> memcmp b1 b2 (fromIntegral s) withb = allocaBytesAligned bufsz 4096 bufsz = 64*1024 diff --git a/src/System/Process/Extra.hs b/src/System/Process/Extra.hs --- a/src/System/Process/Extra.hs +++ b/src/System/Process/Extra.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, ConstraintKinds #-} -- | Extra functions for creating processes. Specifically variants that automatically check --- the 'ExitCode' and capture the 'stdout'\/'stderr' handles. +-- the 'ExitCode' and capture the 'stdout' \/ 'stderr' handles. module System.Process.Extra( module System.Process, system_, systemOutput, systemOutput_ @@ -12,6 +12,7 @@ import System.Process import System.Exit import Data.Functor +import Partial import Prelude @@ -26,7 +27,7 @@ -- | A version of 'system' that throws an error if the 'ExitCode' is not 'ExitSuccess'. -system_ :: String -> IO () +system_ :: Partial => String -> IO () system_ x = do res <- system x when (res /= ExitSuccess) $ @@ -34,9 +35,9 @@ -- | A version of 'system' that captures the output (both 'stdout' and 'stderr') -- and throws an error if the 'ExitCode' is not 'ExitSuccess'. -systemOutput_ :: String -> IO String +systemOutput_ :: Partial => String -> IO String systemOutput_ x = do (res,out) <- systemOutput x when (res /= ExitSuccess) $ error $ "Failed when running system command: " ++ x - return out + pure out diff --git a/src/System/Time/Extra.hs b/src/System/Time/Extra.hs --- a/src/System/Time/Extra.hs +++ b/src/System/Time/Extra.hs @@ -8,15 +8,14 @@ module System.Time.Extra( Seconds, sleep, timeout, - subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration ) where import Control.Concurrent -import Data.Time.Clock import System.Clock import Numeric.Extra +import Control.Monad.IO.Class import Control.Monad.Extra import Control.Exception.Extra import Data.Typeable @@ -28,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 @@ -54,36 +53,26 @@ -- 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) + handleBool (== ex) + (const $ pure Nothing) (bracket (forkIOWithUnmask $ \unmask -> unmask $ sleep n >> throwTo pid ex) killThread (\_ -> fmap Just f)) --- Once we remove subtractTime we can remove the dependency on the time package entire. -{-# DEPRECATED subtractTime "Function is being retired - use diffUTCTime directly." #-} - --- | Calculate the difference between two times in seconds. --- Usually the first time will be the end of an event, and the --- second time will be the beginning. -subtractTime :: UTCTime -> UTCTime -> Seconds -subtractTime end start = fromRational $ toRational $ end `diffUTCTime` start - - -- | Show a number of seconds, typically a duration, in a suitable manner with --- responable precision for a human. +-- reasonable precision for a human. -- -- > showDuration 3.435 == "3.44s" -- > showDuration 623.8 == "10m24s" @@ -102,16 +91,16 @@ -- | 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." #-} +{-# DEPRECATED offsetTimeIncrease "Use 'offsetTime' instead, which is guaranteed to always increase." #-} -- | A synonym for 'offsetTime'. offsetTimeIncrease :: IO (IO Seconds) @@ -119,10 +108,10 @@ -- | Record how long a computation takes in 'Seconds'. -- --- > do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.1 -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) diff --git a/src/Text/Read/Extra.hs b/src/Text/Read/Extra.hs --- a/src/Text/Read/Extra.hs +++ b/src/Text/Read/Extra.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -16,5 +16,6 @@ main :: IO () main = runTests $ do + testSetup tests testCustom diff --git a/test/TestCustom.hs b/test/TestCustom.hs --- a/test/TestCustom.hs +++ b/test/TestCustom.hs @@ -1,30 +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.List.Extra as X -import 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" @@ -33,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 () diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -1,33 +1,54 @@ -- 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\"" $ stringException ("test" ++ undefined) == return "test" - testGen "stringException (\"test\" ++ undefined ++ \"hello\") == return \"test\"" $ stringException ("test" ++ undefined ++ "hello") == return "test" - testGen "stringException ['t','e','s','t',undefined] == return \"test\"" $ stringException ['t','e','s','t',undefined] == return "test" + testGen "stringException \"test\" == pure \"test\"" $ stringException "test" == pure "test" + testGen "stringException (\"test\" ++ undefined) == pure \"test\"" $ stringException ("test" ++ undefined) == pure "test" + testGen "stringException (\"test\" ++ undefined ++ \"hello\") == pure \"test\"" $ stringException ("test" ++ undefined ++ "hello") == pure "test" + testGen "stringException ['t','e','s','t',undefined] == pure \"test\"" $ stringException ['t','e','s','t',undefined] == pure "test" 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) == 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]) testGen "partitionM (const Nothing) [1,2,3] == Nothing" $ partitionM (const Nothing) [1,2,3] == Nothing + testGen "loop (\\x -> if x < 10 then Left $ x * 2 else Right $ show x) 1 == \"16\"" $ loop (\x -> if x < 10 then Left $ x * 2 else Right $ show x) 1 == "16" testGen "Just True ||^ undefined == Just True" $ Just True ||^ undefined == Just True testGen "Just False ||^ Just True == Just True" $ Just False ||^ Just True == Just True testGen "Just False ||^ Just False == Just False" $ Just False ||^ Just False == Just False @@ -63,12 +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 "for [1,2,3] (+1) == [2,3,4]" $ for [1,2,3] (+1) == [2,3,4] 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 @@ -80,12 +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) @@ -93,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" == "" @@ -109,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") @@ -132,18 +170,36 @@ testGen "line1 \"test\\n\" == (\"test\",\"\")" $ line1 "test\n" == ("test","") testGen "line1 \"test\\nrest\" == (\"test\",\"rest\")" $ line1 "test\nrest" == ("test","rest") testGen "line1 \"test\\nrest\\nmore\" == (\"test\",\"rest\\nmore\")" $ line1 "test\nrest\nmore" == ("test","rest\nmore") - 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 "escapeHTML \"this is a test\" == \"this is a test\"" $ escapeHTML "this is a test" == "this is a test" + testGen "escapeHTML \"\\\"g&t\\\"\" == \"<b>"g&t"</n>\"" $ escapeHTML "\"g&t\"" == "<b>"g&t"</n>" + testGen "escapeHTML \"t'was another test\" == \"t'was another test\"" $ escapeHTML "t'was another test" == "t'was another test" + testGen "\\xs -> unescapeHTML (escapeHTML xs) == xs" $ \xs -> unescapeHTML (escapeHTML xs) == xs + testGen "escapeJSON \"this is a test\" == \"this is a test\"" $ escapeJSON "this is a test" == "this is a test" + testGen "escapeJSON \"\\ttab\\nnewline\\\\\" == \"\\\\ttab\\\\nnewline\\\\\\\\\"" $ escapeJSON "\ttab\nnewline\\" == "\\ttab\\nnewline\\\\" + testGen "escapeJSON \"\\ESC[0mHello\" == \"\\\\u001b[0mHello\"" $ escapeJSON "\ESC[0mHello" == "\\u001b[0mHello" + testGen "\\xs -> unescapeJSON (escapeJSON xs) == xs" $ \xs -> unescapeJSON (escapeJSON xs) == xs + testGen "groupOn abs [1,-1,2] == [[1,-1], [2]]" $ groupOn abs [1,-1,2] == [[1,-1], [2]] + testGen "groupOnKey abs [1,-1,2] == [(1, [1,-1]), (2, [2])]" $ groupOnKey abs [1,-1,2] == [(1, [1,-1]), (2, [2])] + testGen "maximumOn id [] == undefined" $ erroneous $ maximumOn id [] + testGen "maximumOn length [\"test\",\"extra\",\"a\"] == \"extra\"" $ maximumOn length ["test","extra","a"] == "extra" + testGen "minimumOn id [] == undefined" $ erroneous $ minimumOn id [] + 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") @@ -162,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") @@ -184,6 +243,11 @@ testGen "last (dropWhileEnd' even [undefined,3]) == 3" $ last (dropWhileEnd' even [undefined,3]) == 3 testGen "head (dropWhileEnd even (3:undefined)) == 3" $ head (dropWhileEnd even (3:undefined)) == 3 testGen "head (dropWhileEnd' even (3:undefined)) == undefined" $ erroneous $ head (dropWhileEnd' even (3:undefined)) + testGen "dropPrefix \"Mr. \" \"Mr. Men\" == \"Men\"" $ dropPrefix "Mr. " "Mr. Men" == "Men" + testGen "dropPrefix \"Mr. \" \"Dr. Men\" == \"Dr. Men\"" $ dropPrefix "Mr. " "Dr. Men" == "Dr. Men" + testGen "dropSuffix \"!\" \"Hello World!\" == \"Hello World\"" $ dropSuffix "!" "Hello World!" == "Hello World" + testGen "dropSuffix \"!\" \"Hello World!!\" == \"Hello World!\"" $ dropSuffix "!" "Hello World!!" == "Hello World!" + testGen "dropSuffix \"!\" \"Hello World.\" == \"Hello World.\"" $ dropSuffix "!" "Hello World." == "Hello World." testGen "stripSuffix \"bar\" \"foobar\" == Just \"foo\"" $ stripSuffix "bar" "foobar" == Just "foo" testGen "stripSuffix \"\" \"baz\" == Just \"baz\"" $ stripSuffix "" "baz" == Just "baz" testGen "stripSuffix \"foo\" \"quux\" == Nothing" $ stripSuffix "foo" "quux" == Nothing @@ -194,19 +258,36 @@ testGen "chunksOf 3 \"mytest\" == [\"myt\",\"est\"]" $ chunksOf 3 "mytest" == ["myt","est"] testGen "chunksOf 8 \"\" == []" $ chunksOf 8 "" == [] testGen "chunksOf 0 \"test\" == undefined" $ erroneous $ chunksOf 0 "test" + testGen "nubSort \"this is a test\" == \" aehist\"" $ nubSort "this is a test" == " aehist" + testGen "\\xs -> nubSort xs == nub (sort xs)" $ \xs -> nubSort xs == nub (sort xs) + testGen "nubSortOn length [\"a\",\"test\",\"of\",\"this\"] == [\"a\",\"of\",\"test\"]" $ nubSortOn length ["a","test","of","this"] == ["a","of","test"] + testGen "nubSortBy (compare `on` length) [\"a\",\"test\",\"of\",\"this\"] == [\"a\",\"of\",\"test\"]" $ nubSortBy (compare `on` length) ["a","test","of","this"] == ["a","of","test"] testGen "nubOrd \"this is a test\" == \"this ae\"" $ nubOrd "this is a test" == "this ae" testGen "nubOrd (take 4 (\"this\" ++ undefined)) == \"this\"" $ nubOrd (take 4 ("this" ++ undefined)) == "this" 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" @@ -215,37 +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 "\\s -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \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 "\\(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) == 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.1" $ do (a,_) <- duration $ sleep 1; return $ a >= 1 && a <= 1.1 + testGen "do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs" $ do f <- offsetTime; xs <- replicateM 10 f; pure $ xs == sort xs + testGen "do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5" $ do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5 diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -1,34 +1,39 @@ -{-# LANGUAGE ScopedTypeVariables, CPP, FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- OK because a test module -module TestUtil(runTests, testGen, testRaw, erroneous, erroneousIO, (====), module X) where +module TestUtil + (runTests + ,testGen, testRaw + ,erroneous, erroneousIO + ,(====), (==>) + ,ASCIIString(..) + ,module X + ) where import Test.QuickCheck -import Test.QuickCheck.Test -import Control.Exception.Extra -import Data.Either.Extra -import System.IO.Extra -import Data.Version.Extra -import Data.IORef import System.IO.Unsafe -import Data.Time.Clock -import Data.Time.Calendar import Text.Show.Functions() -import Extra as X -import Control.Applicative as X -import Control.Monad as X -import Data.Function as X -import Data.List as X +import Control.Concurrent.Extra as X +import Control.Exception.Extra as X +import Control.Monad.Extra as X import Data.Char as X -import Data.Monoid as X -import Data.Tuple as X -import Data.Typeable as X -import Data.Version as X -import System.Directory as X +import Data.Either.Extra as X +import Data.Function as X +import Data.IORef.Extra 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.Version.Extra as X +import Numeric.Extra as X +import System.Directory.Extra as X import System.FilePath as X -import System.Info as X -import Control.Exception as X -import Test.QuickCheck as X((==>)) +import System.Info.Extra as X +import System.IO.Extra as X +import System.Process.Extra as X +import System.Time.Extra as X {-# NOINLINE testCount #-} @@ -38,7 +43,9 @@ testGen :: Testable prop => String -> prop -> IO () testGen msg prop = testRaw msg $ do r <- quickCheckResult prop - unless (isSuccess r) $ error "Test failed" + case r of + Success{} -> pure () + _ -> errorIO "Test failed" testRaw :: String -> IO () -> IO () testRaw msg test = do @@ -58,29 +65,28 @@ | 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 + hSetBuffering stdout NoBuffering + hSetBuffering stderr NoBuffering writeIORef testCount 0 t n <- readIORef testCount putStrLn $ "Success (" ++ show n ++ " tests)" -instance Testable () where - property = property . (`seq` True) - instance Testable a => Testable (IO a) where property = property . unsafePerformIO -instance Eq a => Eq (IO a) where +-- We only use this property to assert equality as a property +-- And the Show instance is useless (since it may be non-deterministic) +-- 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 - return $ a == b + 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 show _ = "<>" @@ -88,19 +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 - -instance Arbitrary UTCTime where - arbitrary = liftM2 UTCTime arbitrary arbitrary - -instance Arbitrary Day where - arbitrary = fmap ModifiedJulianDay arbitrary - -instance Arbitrary DiffTime where - arbitrary = realToFrac <$> choose (0 :: Double, 86401)