extra-1.7.4/0000755000000000000000000000000013703664774011055 5ustar0000000000000000extra-1.7.4/Setup.hs0000644000000000000000000000005612470711455012477 0ustar0000000000000000import Distribution.Simple main = defaultMain extra-1.7.4/README.md0000644000000000000000000000521513457403467012333 0ustar0000000000000000# Extra [![Hackage version](https://img.shields.io/hackage/v/extra.svg?label=Hackage)](https://hackage.haskell.org/package/extra) [![Stackage version](https://www.stackage.org/package/extra/badge/nightly?label=Stackage)](https://www.stackage.org/package/extra) [![Linux build status](https://img.shields.io/travis/ndmitchell/extra/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/extra) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/extra/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/extra) 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. * `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. * I have defined only a few new data types or type aliases. It's a package for defining new utilities on existing types, not new types or concepts. ## Base versions A mapping between `base` versions and GHC compiler versions can be found [here](https://wiki.haskell.org/Base_package#Versions). extra-1.7.4/LICENSE0000644000000000000000000000276413620256530012054 0ustar0000000000000000Copyright Neil Mitchell 2014-2020. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Neil Mitchell nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. extra-1.7.4/Generate.hs0000644000000000000000000001004413627151405013125 0ustar0000000000000000-- This module generates the files src/Extra.hs and test/TestGen.hs. -- Either call "runhaskell Generate" or start "ghci" and use ":generate". 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 import Data.Char import Data.Maybe import Data.Functor import Prelude main :: IO () main = do src <- readFile "extra.cabal" let mods = filter (isSuffixOf ".Extra") $ map trim $ lines src ifaces <- forM mods $ \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 pure (mod, funcs, tests) writeFileBinaryChanged "src/Extra.hs" $ unlines $ ["-- GENERATED CODE - DO NOT MODIFY" ,"-- See Generate.hs for details of how to generate" ,"" ,"-- | This module documents all the functions available in this package." ,"--" ,"-- 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 {-# 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 (++",") $ filter (notHidden mod) funs)] | (mod,funs@(_:_),_) <- ifaces] ++ [" ) where" ,""] ++ ["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 #-}" ,"module TestGen(tests) where" ,"import TestUtil" ,"import qualified Data.List" ,"import qualified Data.List.NonEmpty.Extra" ,"import Test.QuickCheck.Instances.Semigroup ()" ,"default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char))" ,"tests :: IO ()" ,"tests = do"] ++ [" " ++ if "let " `isPrefixOf` t then t else "testGen " ++ show t ++ " $ " ++ tweakTest t | (_,_,ts) <- ifaces, t <- rejoin ts] rejoin :: [String] -> [String] rejoin (x1:x2:xs) | " " `isPrefixOf` x2 = rejoin $ (x1 ++ x2) : xs rejoin (x:xs) = x : rejoin xs rejoin [] = [] writeFileBinaryChanged :: FilePath -> String -> IO () writeFileBinaryChanged file x = do evaluate $ length x -- ensure we don't write out files with _|_ in them old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (pure Nothing) when (Just x /= old) $ writeFileBinary file x hidden :: String -> [String] hidden "Data.List.NonEmpty.Extra" = [ "cons", "snoc", "sortOn", "union", "unionBy" , "nubOrd", "nubOrdBy", "nubOrdOn" ] 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)) && xs `notElem` ["module","Numeric"] isName (x:xs) = isAlpha x && all (\x -> isAlphaNum x || x `elem` "_'") xs isName _ = False tweakTest x | Just x <- stripSuffix " == undefined" x = if not $ "\\" `isPrefixOf` x then (if "fileEq" `isInfixOf` x then "erroneousIO $ " else "erroneous $ ") ++ trim x else let (a,b) = breakOn "->" $ trim x in a ++ "-> erroneous $ " ++ trim (drop 2 b) | otherwise = x extra-1.7.4/extra.cabal0000644000000000000000000000515313703664531013157 0ustar0000000000000000cabal-version: >= 1.18 build-type: Simple name: extra version: 1.7.4 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell copyright: Neil Mitchell 2014-2020 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. . 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.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 extra-doc-files: CHANGES.txt README.md extra-source-files: Generate.hs source-repository head type: git location: https://github.com/ndmitchell/extra.git library default-language: Haskell2010 hs-source-dirs: src build-depends: base >= 4.9 && < 5, directory, filepath, process, clock >= 0.7, time if !os(windows) build-depends: unix other-modules: Partial exposed-modules: Extra Control.Concurrent.Extra Control.Exception.Extra Control.Monad.Extra Data.Either.Extra Data.IORef.Extra Data.List.Extra Data.List.NonEmpty.Extra Data.Tuple.Extra Data.Typeable.Extra Data.Version.Extra Numeric.Extra System.Directory.Extra System.Environment.Extra System.Info.Extra System.IO.Extra System.Process.Extra System.Time.Extra Text.Read.Extra test-suite extra-test type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base == 4.*, directory, filepath, extra, QuickCheck >= 2.10, quickcheck-instances >= 0.3.17 if !os(windows) build-depends: unix hs-source-dirs: test ghc-options: -main-is Test -threaded "-with-rtsopts=-N4 -K1K" main-is: Test.hs other-modules: TestCustom TestGen TestUtil extra-1.7.4/CHANGES.txt0000644000000000000000000001412113703664555012662 0ustar0000000000000000Changelog for Extra 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, released 2017-04-04 Add errorWithoutStackTrace to Control.Exception.Extra 1.5.1, released 2016-10-25 #25, add zipFrom and zipWithFrom #24, add eitherToMaybe and maybeToEither Add fromLeft' and fromRight' 1.5, released 2016-07-21 Change fromLeft/fromRight signatures to follow the base libraries 1.4.12, released 2016-07-18 Add writeVar 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, released 2016-06-15 Add Data.Typeable.Extra containing typeRep, Proxy, (:~:) 1.4.9, released 2016-06-01 Add line1 1.4.8, released 2016-05-26 Add displayException 1.4.7, released 2016-05-22 #21, add concatForM 1.4.6, released 2016-05-11 #11, add maybeM and eitherM 1.4.5, released 2016-04-29 #17, change fileEq on files that do not exist to be an error 1.4.4, released 2016-04-29 #14, add mconcatMap and mconcatMapM #16, add fileEq #15, add isMac 1.4.3, released 2016-01-07 Add Data.Version.Extra 1.4.2, released 2015-09-14 Make concatMapM/mapMaybeM faster 1.4.1, released 2015-08-04 Make temp file functions workaround GHC bug #10731 Add retryBool 1.4, released 2015-07-23 Add stripInfix and stripInfixEnd 1.3.1, released 2015-07-17 #9, support directory-1.2.3 1.3, released 2015-06-20 Add whenJustM Add errorIO 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, released 2015-02-17 #7, add nubOrd, nubOrdOn, nubOrdBy #6, add groupSortOn and groupSortBy #5, add splitAtEnd 1.0.1, released 2015-01-09 Make listFilesAvoid drop trailing path separators before testing #3, add a constraint base >= 4.4 1.0, released 2014-11-27 No changes 0.8, released 2014-11-12 Fix a bug in writeFileEncoding/writeFileUTF8 0.7, released 2014-11-03 Fix for missing case in withNumCapabilities 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, released 2014-10-28 Use uncons from GHC 7.9 and above 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, released 2014-10-23 Remove all but the extractors on triples Remove groupSortOn Remove dropAround 0.3.2, released 2014-10-21 Remove use of ===, allows older QuickCheck versions 0.3.1, released 2014-10-20 Fix a bug in breakEnd/spanEnd 0.3, released 2014-10-18 Rename showTime to showDuration Add stringException Eliminate rep/reps, use replace instead Switch distinct for allSame/anySame Optimise the numeric conversions Rename chop to repeatedly Add whenM/unlessM Redo the Tuple module, additions and deletions Add newTempFile, newTempDir Add createDirectoryPrivate Rename strip* to trim* Generalise showException 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, released 2014-10-06 Initial version, still unstable extra-1.7.4/test/0000755000000000000000000000000013703664774012034 5ustar0000000000000000extra-1.7.4/test/TestUtil.hs0000644000000000000000000000565713662733472014156 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- OK because a test module module TestUtil (runTests ,testGen, testRaw ,erroneous, erroneousIO ,(====), (==>) ,ASCIIString(..) ,module X ) where import Test.QuickCheck import System.IO.Unsafe import Text.Show.Functions() import Control.Applicative as X import Control.Concurrent.Extra as X import Control.Exception.Extra as X import Control.Monad.Extra as X import Data.Char 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 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.Extra as X import System.IO.Extra as X import System.Process.Extra as X import System.Time.Extra as X {-# NOINLINE testCount #-} testCount :: IORef Int testCount = unsafePerformIO $ newIORef 0 testGen :: Testable prop => String -> prop -> IO () testGen msg prop = testRaw msg $ do r <- quickCheckResult prop case r of Success{} -> pure () _ -> errorIO "Test failed" testRaw :: String -> IO () -> IO () testRaw msg test = do putStrLn msg test modifyIORef testCount (+1) erroneous :: Show a => a -> Bool erroneous x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate $ length $ show x erroneousIO :: Show a => IO a -> Bool erroneousIO x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate . length . show =<< x (====) :: (Show a, Eq a) => a -> a -> Bool a ==== b | a == b = True | otherwise = error $ "Not equal!\n" ++ show a ++ "\n" ++ show b 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 a => Testable (IO a) where property = property . unsafePerformIO -- 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 if a == b then pure True else error $ show ("IO values not equal", a, b) instance Show (IO a) where show _ = "<>" instance Arbitrary a => Arbitrary (IO a) where arbitrary = do (prnt :: Maybe Int, thrw :: Maybe Int, res) <- arbitrary pure $ do whenJust prnt print whenJust thrw (fail . show) pure res instance Eq SomeException where a == b = show a == show b extra-1.7.4/test/TestGen.hs0000644000000000000000000010253513666736165013751 0ustar0000000000000000-- GENERATED CODE - DO NOT MODIFY -- See Generate.hs for details of how to generate {-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables, ViewPatterns #-} module TestGen(tests) where import TestUtil import qualified Data.List import qualified Data.List.NonEmpty.Extra import Test.QuickCheck.Instances.Semigroup () default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () tests = do let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2 testGen "\\(x :: IO Int) -> void (once x) == 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\" == 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\") == pure ()" $ ignore (fail "die") == pure () testGen "catch (errorIO \"Hello\") (\\(ErrorCall x) -> pure x) == pure \"Hello\"" $ catch (errorIO "Hello") (\(ErrorCall x) -> pure x) == pure "Hello" testGen "seq (errorIO \"foo\") (print 1) == print 1" $ seq (errorIO "foo") (print 1) == print 1 testGen "retry 1 (print \"x\") == print \"x\"" $ retry 1 (print "x") == print "x" testGen "retry 3 (fail \"die\") == fail \"die\"" $ retry 3 (fail "die") == fail "die" testGen "whenJust Nothing print == pure ()" $ whenJust Nothing print == pure () testGen "whenJust (Just 1) print == print 1" $ whenJust (Just 1) print == print 1 testGen "whenMaybe True (print 1) == fmap Just (print 1)" $ whenMaybe True (print 1) == fmap Just (print 1) testGen "whenMaybe False (print 1) == pure Nothing" $ whenMaybe False (print 1) == pure Nothing testGen "\\(x :: Maybe ()) -> unit x == x" $ \(x :: Maybe ()) -> unit x == x testGen "fold1M (\\x y -> Just x) [] == undefined" $ erroneous $ fold1M (\x y -> Just x) [] testGen "fold1M (\\x y -> Just $ x + y) [1, 2, 3] == Just 6" $ fold1M (\x y -> Just $ x + y) [1, 2, 3] == Just 6 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 testGen "Just False &&^ undefined == Just False" $ Just False &&^ undefined == Just False testGen "Just True &&^ Just True == Just True" $ Just True &&^ Just True == Just True testGen "Just True &&^ Just False == Just False" $ Just True &&^ Just False == Just False testGen "anyM Just [False,True ,undefined] == Just True" $ anyM Just [False,True ,undefined] == Just True testGen "anyM Just [False,False,undefined] == undefined" $ erroneous $ anyM Just [False,False,undefined] testGen "\\(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)" $ \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) testGen "allM Just [True,False,undefined] == Just False" $ allM Just [True,False,undefined] == Just False testGen "allM Just [True,True ,undefined] == undefined" $ erroneous $ allM Just [True,True ,undefined] testGen "\\(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs)" $ \(f :: Int -> Maybe Bool) xs -> anyM f xs == orM (map f xs) testGen "orM [Just False,Just True ,undefined] == Just True" $ orM [Just False,Just True ,undefined] == Just True testGen "orM [Just False,Just False,undefined] == undefined" $ erroneous $ orM [Just False,Just False,undefined] testGen "\\xs -> Just (or xs) == orM (map Just xs)" $ \xs -> Just (or xs) == orM (map Just xs) testGen "andM [Just True,Just False,undefined] == Just False" $ andM [Just True,Just False,undefined] == Just False testGen "andM [Just True,Just True ,undefined] == undefined" $ erroneous $ andM [Just True,Just True ,undefined] testGen "\\xs -> Just (and xs) == andM (map Just xs)" $ \xs -> Just (and xs) == andM (map Just xs) testGen "findM (Just . isUpper) \"teST\" == Just (Just 'S')" $ findM (Just . isUpper) "teST" == Just (Just 'S') testGen "findM (Just . isUpper) \"test\" == Just Nothing" $ findM (Just . isUpper) "test" == Just Nothing testGen "findM (Just . const True) [\"x\",undefined] == Just (Just \"x\")" $ findM (Just . const True) ["x",undefined] == Just (Just "x") testGen "fromLeft 1 (Left 3) == 3" $ fromLeft 1 (Left 3) == 3 testGen "fromLeft 1 (Right \"foo\") == 1" $ fromLeft 1 (Right "foo") == 1 testGen "fromRight 1 (Right 3) == 3" $ fromRight 1 (Right 3) == 3 testGen "fromRight 1 (Left \"foo\") == 1" $ fromRight 1 (Left "foo") == 1 testGen "\\x -> fromLeft' (Left x) == x" $ \x -> fromLeft' (Left x) == x testGen "\\x -> fromLeft' (Right x) == undefined" $ \x -> erroneous $ fromLeft' (Right x) testGen "\\x -> fromRight' (Right x) == x" $ \x -> fromRight' (Right x) == x testGen "\\x -> fromRight' (Left x) == undefined" $ \x -> erroneous $ fromRight' (Left x) testGen "\\x -> fromEither (Left x ) == x" $ \x -> fromEither (Left x ) == x testGen "\\x -> fromEither (Right x) == x" $ \x -> fromEither (Right x) == x testGen "\\a b -> maybeToEither a (Just b) == Right b" $ \a b -> maybeToEither a (Just b) == Right b testGen "\\a -> maybeToEither a Nothing == Left a" $ \a -> maybeToEither a Nothing == Left a testGen "\\x -> eitherToMaybe (Left x) == Nothing" $ \x -> eitherToMaybe (Left x) == Nothing testGen "\\x -> eitherToMaybe (Right x) == Just x" $ \x -> eitherToMaybe (Right x) == Just x testGen "mapLeft show (Left 1) == Left \"1\"" $ mapLeft show (Left 1) == Left "1" testGen "mapLeft show (Right True) == Right True" $ mapLeft show (Right True) == Right True testGen "mapRight show (Left 1) == Left 1" $ mapRight show (Left 1) == Left 1 testGen "mapRight show (Right True) == Right \"True\"" $ mapRight show (Right True) == Right "True" testGen "\\xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs" $ \xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs testGen "\\xs -> repeatedly word1 (trim xs) == words xs" $ \xs -> repeatedly word1 (trim xs) == words xs testGen "\\xs -> repeatedly line1 xs == lines xs" $ \xs -> repeatedly line1 xs == lines xs testGen "disjoint [1,2,3] [4,5] == True" $ disjoint [1,2,3] [4,5] == True testGen "disjoint [1,2,3] [4,1] == False" $ disjoint [1,2,3] [4,1] == False testGen "disjointOrd [1,2,3] [4,5] == True" $ disjointOrd [1,2,3] [4,5] == True testGen "disjointOrd [1,2,3] [4,1] == False" $ disjointOrd [1,2,3] [4,1] == False testGen "disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,5] == True" $ disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,5] == True testGen "disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,8] == False" $ disjointOrdBy (compare `on` (`mod` 7)) [1,2,3] [4,8] == False testGen "anySame [1,1,2] == True" $ anySame [1,1,2] == True testGen "anySame [1,2,3] == False" $ anySame [1,2,3] == False testGen "anySame (1:2:1:undefined) == True" $ anySame (1:2:1:undefined) == True testGen "anySame [] == False" $ anySame [] == False testGen "\\xs -> anySame xs == (length (nub xs) < length xs)" $ \xs -> anySame xs == (length (nub xs) < length xs) testGen "allSame [1,1,2] == False" $ allSame [1,1,2] == False testGen "allSame [1,1,1] == True" $ allSame [1,1,1] == True testGen "allSame [1] == True" $ allSame [1] == True 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 "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 "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) testGen "cons 't' \"est\" == \"test\"" $ cons 't' "est" == "test" 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" == "" testGen "\\i xs -> takeEnd i xs `isSuffixOf` xs" $ \i xs -> takeEnd i xs `isSuffixOf` xs testGen "\\i xs -> length (takeEnd i xs) == min (max 0 i) (length xs)" $ \i xs -> length (takeEnd i xs) == min (max 0 i) (length xs) testGen "dropEnd 3 \"hello\" == \"he\"" $ dropEnd 3 "hello" == "he" testGen "dropEnd 5 \"bye\" == \"\"" $ dropEnd 5 "bye" == "" testGen "dropEnd (-1) \"bye\" == \"bye\"" $ dropEnd (-1) "bye" == "bye" testGen "\\i xs -> dropEnd i xs `isPrefixOf` xs" $ \i xs -> dropEnd i xs `isPrefixOf` xs testGen "\\i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i)" $ \i xs -> length (dropEnd i xs) == max 0 (length xs - max 0 i) testGen "\\i -> take 3 (dropEnd 5 [i..]) == take 3 [i..]" $ \i -> take 3 (dropEnd 5 [i..]) == take 3 [i..] testGen "splitAtEnd 3 \"hello\" == (\"he\",\"llo\")" $ splitAtEnd 3 "hello" == ("he","llo") testGen "splitAtEnd 3 \"he\" == (\"\", \"he\")" $ splitAtEnd 3 "he" == ("", "he") 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] == [(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") testGen "takeWhileEnd even [2,3,4,6] == [4,6]" $ takeWhileEnd even [2,3,4,6] == [4,6] testGen "trim \" hello \" == \"hello\"" $ trim " hello " == "hello" testGen "trimStart \" hello \" == \"hello \"" $ trimStart " hello " == "hello " testGen "trimEnd \" hello \" == \" hello\"" $ trimEnd " hello " == " hello" testGen "\\s -> trim s == trimEnd (trimStart s)" $ \s -> trim s == trimEnd (trimStart s) testGen "lower \"This is A TEST\" == \"this is a test\"" $ lower "This is A TEST" == "this is a test" testGen "lower \"\" == \"\"" $ lower "" == "" testGen "upper \"This is A TEST\" == \"THIS IS A TEST\"" $ upper "This is A TEST" == "THIS IS A TEST" testGen "upper \"\" == \"\"" $ upper "" == "" testGen "word1 \"\" == (\"\", \"\")" $ word1 "" == ("", "") testGen "word1 \"keyword rest of string\" == (\"keyword\",\"rest of string\")" $ word1 "keyword rest of string" == ("keyword","rest of string") testGen "word1 \" keyword\\n rest of string\" == (\"keyword\",\"rest of string\")" $ word1 " keyword\n rest of string" == ("keyword","rest of string") testGen "\\s -> fst (word1 s) == concat (take 1 $ words s)" $ \s -> fst (word1 s) == concat (take 1 $ words s) testGen "\\s -> words (snd $ word1 s) == drop 1 (words s)" $ \s -> words (snd $ word1 s) == drop 1 (words s) testGen "line1 \"\" == (\"\", \"\")" $ line1 "" == ("", "") testGen "line1 \"test\" == (\"test\",\"\")" $ line1 "test" == ("test","") 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 "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 "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 "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 "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") testGen "\\f xs -> breakEnd (not . f) xs == spanEnd f xs" $ \f xs -> breakEnd (not . f) xs == spanEnd f xs testGen "spanEnd isUpper \"youRE\" == (\"you\",\"RE\")" $ spanEnd isUpper "youRE" == ("you","RE") testGen "spanEnd (not . isSpace) \"x y z\" == (\"x y \",\"z\")" $ spanEnd (not . isSpace) "x y z" == ("x y ","z") testGen "\\f xs -> uncurry (++) (spanEnd f xs) == xs" $ \f xs -> uncurry (++) (spanEnd f xs) == xs testGen "\\f xs -> spanEnd f xs == swap (both reverse (span f (reverse xs)))" $ \f xs -> spanEnd f xs == swap (both reverse (span f (reverse xs))) testGen "wordsBy (== ':') \"::xyz:abc::123::\" == [\"xyz\",\"abc\",\"123\"]" $ wordsBy (== ':') "::xyz:abc::123::" == ["xyz","abc","123"] testGen "\\s -> wordsBy isSpace s == words s" $ \s -> wordsBy isSpace s == words s testGen "linesBy (== ':') \"::xyz:abc::123::\" == [\"\",\"\",\"xyz\",\"abc\",\"\",\"123\",\"\"]" $ linesBy (== ':') "::xyz:abc::123::" == ["","","xyz","abc","","123",""] testGen "\\s -> linesBy (== '\\n') s == lines s" $ \s -> linesBy (== '\n') s == lines s testGen "linesBy (== ';') \"my;list;here;\" == [\"my\",\"list\",\"here\"]" $ linesBy (== ';') "my;list;here;" == ["my","list","here"] testGen "firstJust id [Nothing,Just 3] == Just 3" $ firstJust id [Nothing,Just 3] == Just 3 testGen "firstJust id [Nothing,Nothing] == Nothing" $ firstJust id [Nothing,Nothing] == Nothing 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") testGen "breakOn \"/\" \"foobar\" == (\"foobar\", \"\")" $ breakOn "/" "foobar" == ("foobar", "") testGen "\\needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack" $ \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack testGen "breakOnEnd \"::\" \"a::b::c\" == (\"a::b::\", \"c\")" $ breakOnEnd "::" "a::b::c" == ("a::b::", "c") testGen "splitOn \"\\r\\n\" \"a\\r\\nb\\r\\nd\\r\\ne\" == [\"a\",\"b\",\"d\",\"e\"]" $ splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"] testGen "splitOn \"aaa\" \"aaaXaaaXaaaXaaa\" == [\"\",\"X\",\"X\",\"X\",\"\"]" $ splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""] testGen "splitOn \"x\" \"x\" == [\"\",\"\"]" $ splitOn "x" "x" == ["",""] testGen "splitOn \"x\" \"\" == [\"\"]" $ splitOn "x" "" == [""] testGen "\\s x -> s /= \"\" ==> intercalate s (splitOn s x) == x" $ \s x -> s /= "" ==> intercalate s (splitOn s x) == x testGen "\\c x -> splitOn [c] x == split (==c) x" $ \c x -> splitOn [c] x == split (==c) x testGen "split (== 'a') \"aabbaca\" == [\"\",\"\",\"bb\",\"c\",\"\"]" $ split (== 'a') "aabbaca" == ["","","bb","c",""] testGen "split (== 'a') \"\" == [\"\"]" $ split (== 'a') "" == [""] testGen "split (== ':') \"::xyz:abc::123::\" == [\"\",\"\",\"xyz\",\"abc\",\"\",\"123\",\"\",\"\"]" $ split (== ':') "::xyz:abc::123::" == ["","","xyz","abc","","123","",""] testGen "split (== ',') \"my,list,here\" == [\"my\",\"list\",\"here\"]" $ split (== ',') "my,list,here" == ["my","list","here"] testGen "dropWhileEnd isSpace \"ab cde \" == \"ab cde\"" $ dropWhileEnd isSpace "ab cde " == "ab cde" testGen "dropWhileEnd' isSpace \"ab cde \" == \"ab cde\"" $ dropWhileEnd' isSpace "ab cde " == "ab cde" testGen "last (dropWhileEnd even [undefined,3]) == undefined" $ erroneous $ last (dropWhileEnd even [undefined,3]) 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 testGen "stripInfix \"::\" \"a::b::c\" == Just (\"a\", \"b::c\")" $ stripInfix "::" "a::b::c" == Just ("a", "b::c") testGen "stripInfix \"/\" \"foobar\" == Nothing" $ stripInfix "/" "foobar" == Nothing testGen "stripInfixEnd \"::\" \"a::b::c\" == Just (\"a::b\", \"c\")" $ stripInfixEnd "::" "a::b::c" == Just ("a::b", "c") testGen "chunksOf 3 \"my test\" == [\"my \",\"tes\",\"t\"]" $ chunksOf 3 "my test" == ["my ","tes","t"] 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 "(1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5]" $ (1 :| [2,3]) |> 4 |> 5 == 1 :| [2,3,4,5] testGen "[1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5]" $ [1,2,3] |: 4 |> 5 == 1 :| [2,3,4,5] testGen "appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5]" $ appendl (1 :| [2,3]) [4,5] == 1 :| [2,3,4,5] testGen "appendr [1,2,3] (4 :| [5]) == 1 :| [2,3,4,5]" $ appendr [1,2,3] (4 :| [5]) == 1 :| [2,3,4,5] testGen "(1 :| [3, 5, 3]) `union` (4 :| [5, 3, 5, 2]) == 1 :| [3, 5, 3, 4, 2]" $ (1 :| [3, 5, 3]) `union` (4 :| [5, 3, 5, 2]) == 1 :| [3, 5, 3, 4, 2] testGen "Data.List.NonEmpty.Extra.nubOrd (1 :| [2, 3, 3, 4, 1, 2]) == 1 :| [2, 3, 4]" $ Data.List.NonEmpty.Extra.nubOrd (1 :| [2, 3, 3, 4, 1, 2]) == 1 :| [2, 3, 4] testGen "\\xs -> Data.List.NonEmpty.Extra.nubOrd xs == Data.List.NonEmpty.Extra.nub xs" $ \xs -> Data.List.NonEmpty.Extra.nubOrd xs == Data.List.NonEmpty.Extra.nub xs testGen "Data.List.NonEmpty.Extra.nubOrdBy (compare `on` Data.List.length) (\"a\" :| [\"test\",\"of\",\"this\"]) == \"a\" :| [\"test\",\"of\"]" $ Data.List.NonEmpty.Extra.nubOrdBy (compare `on` Data.List.length) ("a" :| ["test","of","this"]) == "a" :| ["test","of"] testGen "Data.List.NonEmpty.Extra.nubOrdOn Data.List.length (\"a\" :| [\"test\",\"of\",\"this\"]) == \"a\" :| [\"test\",\"of\"]" $ Data.List.NonEmpty.Extra.nubOrdOn Data.List.length ("a" :| ["test","of","this"]) == "a" :| ["test","of"] testGen "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 "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" testGen "showDP 0 pi == \"3\"" $ showDP 0 pi == "3" testGen "showDP 2 3 == \"3.00\"" $ showDP 2 3 == "3.00" 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; 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 $ pure . not . isPrefixOf \".\" . takeFileName) [\"bar.txt\",\"foo\" \"baz.txt\",\".foo\" \"baz2.txt\", \"zoo\"] [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"]" $ listTest (listFilesInside $ pure . not . isPrefixOf "." . takeFileName) ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] testGen "listTest (listFilesInside $ const $ pure False) [\"bar.txt\"] []" $ listTest (listFilesInside $ const $ pure False) ["bar.txt"] [] testGen "isWindows == (os == \"mingw32\")" $ isWindows == (os == "mingw32") testGen "\\(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \\file -> do writeFile file s; readFile' file" $ \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file testGen "\\s -> withTempFile $ \\file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file" $ \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file testGen "\\(ASCIIString s) -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \(ASCIIString s) -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file testGen "captureOutput (print 1) == 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) == 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; 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; 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 extra-1.7.4/test/TestCustom.hs0000644000000000000000000000223213662734744014500 0ustar0000000000000000 module TestCustom(testCustom) where import Control.Concurrent.Extra import Control.Monad import System.IO.Extra import Data.IORef import TestUtil import Data.List.Extra as X testCustom :: IO () testCustom = do -- check that Extra really does export these things testGen "Extra export" $ X.sort [1] == [1] testRaw "withTempFile" $ do xs <- replicateM 4 $ onceFork $ do replicateM_ 100 $ withTempFile (const $ pure ()) putChar '.' sequence_ xs putStrLn "done" testRaw "withTempDir" $ do xs <- replicateM 4 $ onceFork $ do replicateM_ 100 $ withTempDir (const $ pure ()) putChar '.' sequence_ xs putStrLn "done" testGen "retry" $ do 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 () extra-1.7.4/test/Test.hs0000644000000000000000000000047212710624054013272 0ustar0000000000000000 module Test(main) where import TestGen import TestUtil import TestCustom -- Check that we managed to export everything _unused1 x = whenJust _unused2 x = (&&^) _unused3 x = system_ _unused4 x = word1 _unused5 x = readFile' _unused6 x = x :: Seconds main :: IO () main = runTests $ do tests testCustom extra-1.7.4/src/0000755000000000000000000000000013703664774011644 5ustar0000000000000000extra-1.7.4/src/Partial.hs0000644000000000000000000000216113212242400013541 0ustar0000000000000000{-# 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 extra-1.7.4/src/Extra.hs0000644000000000000000000001125213703664537013261 0ustar0000000000000000-- GENERATED CODE - DO NOT MODIFY -- See Generate.hs for details of how to generate -- | This module documents all the functions available in this package. -- -- 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 {-# DEPRECATED "This module is provided as documentation of all new functions, you should import the more specific modules directly." #-} ( -- * Control.Concurrent.Extra -- | Extra functions available in @"Control.Concurrent.Extra"@. withNumCapabilities, once, onceFork, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, writeVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, -- * Control.Exception.Extra -- | Extra functions available in @"Control.Exception.Extra"@. Partial, retry, retryBool, errorWithoutStackTrace, showException, stringException, errorIO, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, -- * Control.Monad.Extra -- | Extra functions available in @"Control.Monad.Extra"@. whenJust, whenJustM, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, loop, loopM, whileM, whileJustM, untilJustM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, fold1M, fold1M_, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, -- * Data.Either.Extra -- | Extra functions available in @"Data.Either.Extra"@. fromLeft, fromRight, fromEither, fromLeft', fromRight', eitherToMaybe, maybeToEither, mapLeft, mapRight, -- * Data.IORef.Extra -- | Extra functions available in @"Data.IORef.Extra"@. writeIORef', atomicWriteIORef', atomicModifyIORef_, atomicModifyIORef'_, -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, headDef, lastDef, notNull, list, unsnoc, cons, snoc, drop1, dropEnd1, mconcatMap, enumerate, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, disjointOrd, disjointOrdBy, allSame, anySame, repeatedly, 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.Tuple.Extra -- | Extra functions available in @"Data.Tuple.Extra"@. first, second, (***), (&&&), dupe, both, firstM, secondM, fst3, snd3, thd3, first3, second3, third3, curry3, uncurry3, -- * Data.Version.Extra -- | Extra functions available in @"Data.Version.Extra"@. readVersion, -- * Numeric.Extra -- | Extra functions available in @"Numeric.Extra"@. showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat, -- * System.Directory.Extra -- | Extra functions available in @"System.Directory.Extra"@. withCurrentDirectory, createDirectoryPrivate, listContents, listDirectories, listFiles, listFilesInside, listFilesRecursive, -- * System.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, 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, showDuration, offsetTime, offsetTimeIncrease, duration, ) where import Control.Concurrent.Extra import Control.Exception.Extra import Control.Monad.Extra import Data.Either.Extra import Data.IORef.Extra import Data.List.Extra import Data.List.NonEmpty.Extra hiding (cons, snoc, sortOn, union, unionBy, nubOrd, nubOrdBy, nubOrdOn) import Data.Tuple.Extra import Data.Version.Extra import Numeric.Extra import System.Directory.Extra import System.Info.Extra import System.IO.Extra import System.Process.Extra import System.Time.Extra extra-1.7.4/src/Text/0000755000000000000000000000000013703664774012570 5ustar0000000000000000extra-1.7.4/src/Text/Read/0000755000000000000000000000000013703664774013443 5ustar0000000000000000extra-1.7.4/src/Text/Read/Extra.hs0000644000000000000000000000041713660217357015055 0ustar0000000000000000 -- | This module provides "Text.Read" with functions added in later versions. -- -- Currently this module has no functionality beyond "Text.Read". module Text.Read.Extra {-# DEPRECATED "Use Text.Read directly" #-} ( module Text.Read, ) where import Text.Read extra-1.7.4/src/System/0000755000000000000000000000000013703664774013130 5ustar0000000000000000extra-1.7.4/src/System/Time/0000755000000000000000000000000013703664774014026 5ustar0000000000000000extra-1.7.4/src/System/Time/Extra.hs0000644000000000000000000000741413662740515015443 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} -- | Extra functions for working with times. Unlike the other modules in this package, there is no -- corresponding @System.Time@ module. This module enhances the functionality -- from "Data.Time.Clock", but in quite different ways. -- -- Throughout, time is measured in 'Seconds', which is a type alias for 'Double'. module System.Time.Extra( Seconds, sleep, timeout, showDuration, offsetTime, offsetTimeIncrease, duration ) where import Control.Concurrent import System.Clock import Numeric.Extra import Control.Monad.IO.Class import Control.Monad.Extra import Control.Exception.Extra import Data.Typeable import Data.Unique -- | A type alias for seconds, which are stored as 'Double'. type Seconds = Double -- | Sleep for a number of seconds. -- -- > 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 pure $ Right () else if s > 2000 then do threadDelay 2000000000 -- 2000 * 1e6 pure $ Left $ s - 2000 else do threadDelay $ ceiling $ s * 1000000 pure $ Right () -- An internal type that is thrown as a dynamic exception to -- interrupt the running IO computation when the timeout has -- expired. newtype Timeout = Timeout Unique deriving (Eq,Typeable) instance Show Timeout where show _ = "<>" instance Exception Timeout -- | A version of 'System.Timeout.timeout' that takes 'Seconds' and never -- overflows the bounds of an 'Int'. In addition, the bug that negative -- timeouts run for ever has been fixed. -- -- > 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; 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 = pure Nothing | otherwise = do pid <- myThreadId ex <- fmap Timeout newUnique handleBool (== ex) (const $ pure Nothing) (bracket (forkIOWithUnmask $ \unmask -> unmask $ sleep n >> throwTo pid ex) killThread (\_ -> fmap Just f)) -- | Show a number of seconds, typically a duration, in a suitable manner with -- reasonable precision for a human. -- -- > showDuration 3.435 == "3.44s" -- > showDuration 623.8 == "10m24s" -- > showDuration 62003.8 == "17h13m" -- > showDuration 1e8 == "27777h47m" showDuration :: Seconds -> String showDuration x | x >= 3600 = f (x / 60) "h" "m" | x >= 60 = f x "m" "s" | otherwise = showDP 2 x ++ "s" where f x m s = show ms ++ m ++ ['0' | ss < 10] ++ show ss ++ s where (ms,ss) = round x `divMod` 60 -- | 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; pure $ xs == sort xs offsetTime :: IO (IO Seconds) offsetTime = do start <- time pure $ do end <- time pure $ 1e-9 * fromIntegral (toNanoSecs $ end - start) where time = getTime Monotonic {-# DEPRECATED offsetTimeIncrease "Use 'offsetTime' instead, which is guaranteed to always increase." #-} -- | A synonym for 'offsetTime'. offsetTimeIncrease :: IO (IO Seconds) offsetTimeIncrease = offsetTime -- | Record how long a computation takes in 'Seconds'. -- -- > do (a,_) <- duration $ sleep 1; pure $ a >= 1 && a <= 1.5 duration :: MonadIO m => m a -> m (Seconds, a) duration act = do time <- liftIO offsetTime res <- act time <- liftIO time pure (time, res) extra-1.7.4/src/System/Process/0000755000000000000000000000000013703664774014546 5ustar0000000000000000extra-1.7.4/src/System/Process/Extra.hs0000644000000000000000000000272313626156442016161 0ustar0000000000000000{-# LANGUAGE TupleSections, ConstraintKinds #-} -- | Extra functions for creating processes. Specifically variants that automatically check -- the 'ExitCode' and capture the 'stdout' \/ 'stderr' handles. module System.Process.Extra( module System.Process, system_, systemOutput, systemOutput_ ) where import Control.Monad import System.IO.Extra import System.Process import System.Exit import Data.Functor import Partial import Prelude -- | A version of 'system' that also captures the output, both 'stdout' and 'stderr'. -- Returns a pair of the 'ExitCode' and the output. systemOutput :: String -> IO (ExitCode, String) systemOutput x = withTempFile $ \file -> do exit <- withFile file WriteMode $ \h -> do (_, _, _, pid) <- createProcess (shell x){std_out=UseHandle h, std_err=UseHandle h} waitForProcess pid (exit,) <$> readFile' file -- | A version of 'system' that throws an error if the 'ExitCode' is not 'ExitSuccess'. system_ :: Partial => String -> IO () system_ x = do res <- system x when (res /= ExitSuccess) $ error $ "Failed when running system command: " ++ x -- | A version of 'system' that captures the output (both 'stdout' and 'stderr') -- and throws an error if the 'ExitCode' is not 'ExitSuccess'. systemOutput_ :: Partial => String -> IO String systemOutput_ x = do (res,out) <- systemOutput x when (res /= ExitSuccess) $ error $ "Failed when running system command: " ++ x pure out extra-1.7.4/src/System/IO/0000755000000000000000000000000013703664774013437 5ustar0000000000000000extra-1.7.4/src/System/IO/Extra.hs0000644000000000000000000002205013626156442015045 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | 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. module System.IO.Extra( module System.IO, captureOutput, withBuffering, -- * Read encoding readFileEncoding, readFileUTF8, readFileBinary, -- * Strict reading readFile', readFileEncoding', readFileUTF8', readFileBinary', -- * Write with encoding writeFileEncoding, writeFileUTF8, writeFileBinary, -- * Temporary files withTempFile, withTempDir, newTempFile, newTempDir, newTempFileWithin, newTempDirWithin, -- * File comparison fileEq, ) where import System.IO import Control.Concurrent.Extra import Control.Monad.Extra import Control.Exception.Extra as E import GHC.IO.Handle(hDuplicate,hDuplicateTo) import System.Directory.Extra import System.IO.Error import System.IO.Unsafe import System.FilePath import Data.Char import Data.Time.Clock import Data.Tuple.Extra import Data.IORef import Foreign.Ptr import Foreign.Marshal.Alloc import Foreign.C.Types import Data.Functor import Prelude -- File reading -- | Like 'readFile', but setting an encoding. readFileEncoding :: TextEncoding -> FilePath -> IO String readFileEncoding enc file = do h <- openFile file ReadMode hSetEncoding h enc hGetContents h -- | Like 'readFile', but with the encoding 'utf8'. readFileUTF8 :: FilePath -> IO String readFileUTF8 = readFileEncoding utf8 -- | Like 'readFile', but for binary files. readFileBinary :: FilePath -> IO String readFileBinary file = do h <- openBinaryFile file ReadMode hGetContents h -- Strict file reading -- | A strict version of 'hGetContents'. hGetContents' :: Handle -> IO String hGetContents' h = do s <- hGetContents h void $ evaluate $ length 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. -- Closing the file handle does not rely on the garbage collector. -- -- > \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file readFile' :: FilePath -> IO String readFile' file = withFile file ReadMode hGetContents' -- | 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 -- | A strict version of 'readFileUTF8', see 'readFile'' for details. readFileUTF8' :: FilePath -> IO String readFileUTF8' = readFileEncoding' utf8 -- | A strict version of 'readFileBinary', see 'readFile'' for details. readFileBinary' :: FilePath -> IO String readFileBinary' file = withBinaryFile file ReadMode hGetContents' -- File writing -- | Write a file with a particular encoding. writeFileEncoding :: TextEncoding -> FilePath -> String -> IO () writeFileEncoding enc file x = withFile file WriteMode $ \h -> do hSetEncoding h enc hPutStr h x -- | Write a file with the 'utf8' encoding. -- -- > \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file writeFileUTF8 :: FilePath -> String -> IO () writeFileUTF8 = writeFileEncoding utf8 -- | Write a binary 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 -- Console -- | Capture the 'stdout' and 'stderr' of a computation. -- -- > captureOutput (print 1) == pure ("1\n",()) captureOutput :: IO a -> IO (String, a) captureOutput act = withTempFile $ \file -> withFile file ReadWriteMode $ \h -> do res <- clone stdout h $ clone stderr h $ do hClose h act out <- readFile' file pure (out, res) where clone out h act = do buf <- hGetBuffering out out2 <- hDuplicate out hDuplicateTo h out act `finally` do hDuplicateTo out2 out hClose out2 hSetBuffering out buf -- | Execute an action with a custom 'BufferMode', a wrapper around -- 'hSetBuffering'. withBuffering :: Handle -> BufferMode -> IO a -> IO a withBuffering h m act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do hSetBuffering h m act --------------------------------------------------------------------- -- TEMPORARY FILE -- We don't use GHC's temp file code, because its buggy, see: -- https://ghc.haskell.org/trac/ghc/ticket/10731 {-# NOINLINE tempRef #-} tempRef :: IORef Int tempRef = unsafePerformIO $ do rand :: Integer <- fmap (read . reverse . filter isDigit . show . utctDayTime) getCurrentTime newIORef $ fromIntegral rand tempUnique :: IO Int tempUnique = atomicModifyIORef tempRef $ succ &&& succ -- | Provide a function to create a temporary file, and a way to delete a -- temporary file. Most users should use 'withTempFile' which -- combines these operations. newTempFile :: IO (FilePath, IO ()) 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 pure (file, del) where create = do val <- tempUnique (file, h) <- retryBool (\(_ :: IOError) -> True) 5 $ openTempFile tmpdir $ "extra-file-" ++ show val ++ "-" hClose h pure file -- | Create a temporary file in the temporary directory. The file will be deleted -- after the action completes (provided the file is not still open). -- 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 == pure True -- > (doesFileExist =<< withTempFile pure) == pure False -- > withTempFile readFile' == pure "" withTempFile :: (FilePath -> IO a) -> IO a withTempFile act = do (file, del) <- newTempFile act file `finally` del -- | Provide a function to create a temporary directory, and a way to delete a -- temporary directory. Most users should use 'withTempDir' which -- combines these operations. newTempDir :: IO (FilePath, IO ()) 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 pure (dir, del) where create tmpdir = do v <- tempUnique let dir = tmpdir "extra-dir-" ++ show v catchBool isAlreadyExistsError (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 == pure True -- > (doesDirectoryExist =<< withTempDir pure) == pure False -- > withTempDir listFiles == pure [] withTempDir :: (FilePath -> IO a) -> IO a withTempDir act = do (dir,del) <- newTempDir act dir `finally` del -- | Returns 'True' when both files have the same size. sameSize :: Handle -> Handle -> IO Bool sameSize h1 h2 = liftM2 (==) (hFileSize h1) (hFileSize h2) foreign import ccall unsafe "string.h memcmp" memcmp :: Ptr CUChar -> Ptr CUChar -> CSize -> IO CInt -- | 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 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 -- | Returns 'True' if both files have the same content. -- Raises an error if either file is missing. -- -- > fileEq "does_not_exist1" "does_not_exist2" == undefined -- > fileEq "does_not_exist" "does_not_exist" == undefined -- > withTempFile $ \f1 -> fileEq "does_not_exist" f1 == undefined -- > withTempFile $ \f1 -> withTempFile $ \f2 -> fileEq f1 f2 -- > withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "a" >> fileEq f1 f2 -- > withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "b" >> notM (fileEq f1 f2) fileEq :: FilePath -> FilePath -> IO Bool fileEq p1 p2 = withH p1 $ \h1 -> withH p2 $ \h2 -> sameContent h1 h2 where withH p = withBinaryFile p ReadMode extra-1.7.4/src/System/Info/0000755000000000000000000000000013703664774014023 5ustar0000000000000000extra-1.7.4/src/System/Info/Extra.hs0000644000000000000000000000155113541745207015433 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Extra functions for the current system info. module System.Info.Extra( module System.Info, isWindows, isMac, ) where import System.Info --------------------------------------------------------------------- -- System.Info -- | Return 'True' on Windows and 'False' otherwise. A runtime version of @#ifdef minw32_HOST_OS@. -- Equivalent to @os == \"mingw32\"@, but: more efficient; doesn't require typing an easily -- mistypeable string; actually asks about your OS not a library; doesn't bake in -- 32bit assumptions that are already false. \<\/rant\> -- -- > isWindows == (os == "mingw32") isWindows :: Bool #if defined(mingw32_HOST_OS) isWindows = True #else isWindows = False #endif -- | Return 'True' on Mac OS X and 'False' otherwise. isMac :: Bool #if defined(darwin_HOST_OS) isMac = True #else isMac = False #endif extra-1.7.4/src/System/Environment/0000755000000000000000000000000013703664774015434 5ustar0000000000000000extra-1.7.4/src/System/Environment/Extra.hs0000644000000000000000000000043613662733423017046 0ustar0000000000000000 -- | 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, ) where import System.Environment extra-1.7.4/src/System/Directory/0000755000000000000000000000000013703664774015074 5ustar0000000000000000extra-1.7.4/src/System/Directory/Extra.hs0000644000000000000000000001054213626156442016505 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef MIN_VERSION_directory #if __GLASGOW_HASKELL__ >= 711 #define MIN_VERSION_directory(a,b,c) 1 #else #define MIN_VERSION_directory(a,b,c) 0 #endif #endif -- | Extra directory functions. Most of these functions provide cleaned up and generalised versions -- of 'getDirectoryContents', see 'listContents' for the differences. module System.Directory.Extra( module System.Directory, #if !MIN_VERSION_directory(1,2,3) withCurrentDirectory, #endif createDirectoryPrivate, listContents, listDirectories, listFiles, listFilesInside, listFilesRecursive ) where import System.Directory import Control.Monad.Extra import System.FilePath import Data.List #if !MIN_VERSION_directory(1,2,3) import Control.Exception #endif #ifndef mingw32_HOST_OS import qualified System.Posix #endif #if !MIN_VERSION_directory(1,2,3) -- | Set the current directory, perform an operation, then change back. -- Remember that the current directory is a global variable, so calling this function -- multithreaded is almost certain to go wrong. Avoid changing the current directory if you can. -- -- > withTempDir $ \dir -> do writeFile (dir "foo.txt") ""; withCurrentDirectory dir $ doesFileExist "foo.txt" withCurrentDirectory :: FilePath -> IO a -> IO a withCurrentDirectory dir act = bracket getCurrentDirectory setCurrentDirectory $ const $ do setCurrentDirectory dir; act #endif -- | List the files and directories directly within a directory. -- Each result will be prefixed by the query directory, and the special directories @.@ and @..@ will be ignored. -- Intended as a cleaned up version of 'getDirectoryContents'. -- -- > 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; 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 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. -- -- > listTest listFiles ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","zoo"] listFiles :: FilePath -> IO [FilePath] listFiles dir = filterM doesFileExist =<< listContents dir -- | Like 'listFiles', but goes recursively through all subdirectories. -- This function will follow symlinks, and if they form a loop, this function will not terminate. -- -- > listTest listFilesRecursive ["bar.txt","zoo","foo" "baz.txt"] ["bar.txt","zoo","foo" "baz.txt"] listFilesRecursive :: FilePath -> IO [FilePath] 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 $ pure . not . isPrefixOf "." . takeFileName) -- > ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] -- > listTest (listFilesInside $ const $ pure False) ["bar.txt"] [] listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir rest <- concatMapM (listFilesInside test) dirs pure $ files ++ rest -- | Create a directory with permissions so that only the current user can view it. -- On Windows this function is equivalent to 'createDirectory'. createDirectoryPrivate :: String -> IO () #ifdef mingw32_HOST_OS createDirectoryPrivate s = createDirectory s #else createDirectoryPrivate s = System.Posix.createDirectory s 0o700 #endif extra-1.7.4/src/Numeric/0000755000000000000000000000000013703664774013246 5ustar0000000000000000extra-1.7.4/src/Numeric/Extra.hs0000644000000000000000000000220113435006774014650 0ustar0000000000000000 -- | Extra numeric functions - formatting and specialised conversions. module Numeric.Extra( module Numeric, showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat ) where import Numeric --------------------------------------------------------------------- -- Data.String -- | Show a number to a fixed number of decimal places. -- -- > showDP 4 pi == "3.1416" -- > showDP 0 pi == "3" -- > showDP 2 3 == "3.00" showDP :: RealFloat a => Int -> a -> String showDP n x = showFFloat (Just n) x "" --------------------------------------------------------------------- -- Numeric -- | Specialised numeric conversion, type restricted version of 'fromIntegral'. intToDouble :: Int -> Double intToDouble = fromIntegral -- | Specialised numeric conversion, type restricted version of 'fromIntegral'. intToFloat :: Int -> Float intToFloat = fromIntegral -- | Specialised numeric conversion, type restricted version of 'realToFrac'. floatToDouble :: Float -> Double floatToDouble = realToFrac -- | Specialised numeric conversion, type restricted version of 'realToFrac'. doubleToFloat :: Double -> Float doubleToFloat = realToFrac extra-1.7.4/src/Data/0000755000000000000000000000000013703664774012515 5ustar0000000000000000extra-1.7.4/src/Data/Version/0000755000000000000000000000000013703664774014142 5ustar0000000000000000extra-1.7.4/src/Data/Version/Extra.hs0000644000000000000000000000135513537516732015560 0ustar0000000000000000{-# 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, readVersion ) where import Partial import Data.Version import Data.List.Extra import Text.ParserCombinators.ReadP -- | Read a 'Version' or throw an exception. -- -- > \x -> readVersion (showVersion x) == x -- > readVersion "hello" == undefined readVersion :: Partial => String -> Version readVersion s = case [ x | (x,"") <- readP_to_S parseVersion $ trimEnd s] of [x] -> x [] -> error "Data.Version.Extra.readVersion: no parse" _ -> error "Data.Version.Extra.readVersion: ambiguous parse" extra-1.7.4/src/Data/Typeable/0000755000000000000000000000000013703664774014262 5ustar0000000000000000extra-1.7.4/src/Data/Typeable/Extra.hs0000644000000000000000000000057113662733400015667 0ustar0000000000000000 -- | This module extends "Data.Typeable" with extra functions available in later GHC versions. -- The package also exports the existing "Data.Typeable" functions. -- -- 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 extra-1.7.4/src/Data/Tuple/0000755000000000000000000000000013703664774013606 5ustar0000000000000000extra-1.7.4/src/Data/Tuple/Extra.hs0000644000000000000000000000605413666736176015236 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | Extra functions for working with pairs and triples. -- Some of these functions are available in the "Control.Arrow" module, -- but here are available specialised to pairs. Some operations work on triples. module Data.Tuple.Extra( module Data.Tuple, -- * Specialised 'Arrow' functions first, second, (***), (&&&), -- * More pair operations dupe, both, -- * Monadic versions firstM, secondM, -- * Operations on triple fst3, snd3, thd3, first3, second3, third3, curry3, uncurry3 ) where import Data.Tuple import qualified Control.Arrow as Arrow infixr 3 ***, &&& -- | Update the first component of a pair. -- -- > first succ (1,"test") == (2,"test") first :: (a -> a') -> (a, b) -> (a', b) first = Arrow.first -- | Update the second component of a pair. -- -- > second reverse (1,"test") == (1,"tset") 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.***'. -- -- > (succ *** reverse) (1,"test") == (2,"tset") (***) :: (a -> a') -> (b -> b') -> (a, b) -> (a', b') (***) = (Arrow.***) -- | Given two functions, apply both to a single argument to form a pair. -- A specialised version of 'Control.Arrow.&&&'. -- -- > (succ &&& pred) 1 == (2,0) (&&&) :: (a -> b) -> (a -> c) -> a -> (b, c) (&&&) = (Arrow.&&&) -- | Duplicate a single value into a pair. -- -- > dupe 12 == (12, 12) dupe :: a -> (a,a) dupe x = (x,x) -- | Apply a single function to both components of a pair. -- -- > both succ (1,2) == (2,3) both :: (a -> b) -> (a, a) -> (b, b) both f (x,y) = (f x, f y) -- | Extract the 'fst' of a triple. fst3 :: (a,b,c) -> a fst3 (a,b,c) = a -- | Extract the 'snd' of a triple. snd3 :: (a,b,c) -> b snd3 (a,b,c) = b -- | 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) extra-1.7.4/src/Data/List/0000755000000000000000000000000013703664774013430 5ustar0000000000000000extra-1.7.4/src/Data/List/Extra.hs0000644000000000000000000007176113703664537015060 0ustar0000000000000000{-# LANGUAGE TupleSections, ConstraintKinds #-} -- | 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. module Data.List.Extra( module Data.List, -- * String operations lower, upper, trim, trimStart, trimEnd, word1, line1, escapeHTML, escapeJSON, unescapeHTML, unescapeJSON, -- * Splitting dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, dropPrefix, dropSuffix, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, -- * Basics headDef, lastDef, notNull, list, unsnoc, cons, snoc, drop1, dropEnd1, mconcatMap, -- * Enum operations enumerate, -- * List operations groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, nubSort, nubSortBy, nubSortOn, maximumOn, minimumOn, disjoint, disjointOrd, disjointOrdBy, allSame, anySame, repeatedly, firstJust, concatUnzip, concatUnzip3, 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 Prelude -- | Apply some operation repeatedly, producing an element of output -- and the remainder of the list. -- -- > \xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs -- > \xs -> repeatedly word1 (trim xs) == words xs -- > \xs -> repeatedly line1 xs == lines xs repeatedly :: ([a] -> (b, [a])) -> [a] -> [b] repeatedly f [] = [] repeatedly f as = b : repeatedly f as' where (b, as') = f as -- | Are two lists disjoint, with no elements in common. -- -- > disjoint [1,2,3] [4,5] == True -- > disjoint [1,2,3] [4,1] == False 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 inifite, 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 -- > anySame [1,2,3] == False -- > anySame (1:2:1:undefined) == True -- > anySame [] == False -- > \xs -> anySame xs == (length (nub xs) < length xs) anySame :: Eq a => [a] -> Bool anySame = f [] where f seen (x:xs) = x `elem` seen || f (x:seen) xs f seen [] = False -- | Are all elements the same. -- -- > allSame [1,1,2] == False -- > allSame [1,1,1] == True -- > allSame [1] == True -- > allSame [] == True -- > allSame (1:1:2:undefined) == False -- > \xs -> allSame xs == (length (nub xs) <= 1) allSame :: Eq a => [a] -> Bool allSame [] = True 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 #-} -- | 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 -- > list 1 (\v _ -> v - 2) [] == 1 -- > \nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs list :: b -> (a -> [a] -> b) -> [a] -> b list nil cons [] = nil list nil cons (x:xs) = cons x xs -- | If the list is empty returns 'Nothing', otherwise returns the 'init' and the 'last'. -- -- > unsnoc "test" == Just ("tes",'t') -- > unsnoc "" == Nothing -- > \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs) unsnoc :: [a] -> Maybe ([a], a) unsnoc [] = Nothing unsnoc [x] = Just ([], x) unsnoc (x:xs) = Just (x:a, b) where Just (a,b) = unsnoc xs -- | Append an element to the start of a list, an alias for '(:)'. -- -- > cons 't' "est" == "test" -- > \x xs -> uncons (cons x xs) == Just (x,xs) cons :: a -> [a] -> [a] cons = (:) -- | Append an element to the end of a list, takes /O(n)/ time. -- -- > snoc "tes" 't' == "test" -- > \xs x -> unsnoc (snoc xs x) == Just (xs,x) snoc :: [a] -> a -> [a] 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" -- > takeEnd 5 "bye" == "bye" -- > takeEnd (-1) "bye" == "" -- > \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) where f (x:xs) (y:ys) = f xs ys f xs _ = xs -- | Drop a number of elements from the end of the list. -- -- > dropEnd 3 "hello" == "he" -- > dropEnd 5 "bye" == "" -- > dropEnd (-1) "bye" == "bye" -- > \i xs -> dropEnd i xs `isPrefixOf` xs -- > \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) where f (x:xs) (y:ys) = x : f xs ys f _ _ = [] -- | @'splitAtEnd' n xs@ returns a split where the second element tries to -- contain @n@ elements. -- -- > splitAtEnd 3 "hello" == ("he","llo") -- > splitAtEnd 3 "he" == ("", "he") -- > \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) 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. -- -- > \i xs -> zip [i..] xs == zipFrom i xs -- > zipFrom False [1..3] == [(False,1),(True, 2)] zipFrom :: Enum a => a -> [b] -> [(a, b)] zipFrom = zipWithFrom (,) -- | 'zipFrom' generalised to any combining operation. -- Never truncates the output - raises an error if the enumeration runs out. -- -- > \i xs -> zipWithFrom (,) i xs == zipFrom i xs zipWithFrom :: Enum a => (a -> b -> c) -> a -> [b] -> [c] -- would love to deforest the intermediate [a..] list -- but would require Bounded and Eq as well, so better go for simplicit zipWithFrom f a = zipWith f [a..] -- | A merging of 'unzip' and 'concat'. -- -- > concatUnzip [("a","AB"),("bc","C")] == ("abc","ABC") concatUnzip :: [([a], [b])] -> ([a], [b]) concatUnzip = (concat *** concat) . unzip -- | A merging of 'unzip3' and 'concat'. -- -- > concatUnzip3 [("a","AB",""),("bc","C","123")] == ("abc","ABC","123") concatUnzip3 :: [([a],[b],[c])] -> ([a],[b],[c]) concatUnzip3 xs = (concat a, concat b, concat c) where (a,b,c) = unzip3 xs -- | A version of 'takeWhile' operating from the end. -- -- > takeWhileEnd even [2,3,4,6] == [4,6] takeWhileEnd :: (a -> Bool) -> [a] -> [a] takeWhileEnd f = reverse . takeWhile f . reverse -- | Remove spaces from the start of a string, see 'trim'. trimStart :: String -> String trimStart = dropWhile isSpace -- | Remove spaces from the end of a string, see 'trim'. trimEnd :: String -> String trimEnd = dropWhileEnd isSpace -- | Remove spaces from either side of a string. A combination of 'trimEnd' and 'trimStart'. -- -- > trim " hello " == "hello" -- > trimStart " hello " == "hello " -- > trimEnd " hello " == " hello" -- > \s -> trim s == trimEnd (trimStart s) trim :: String -> String trim = trimEnd . trimStart -- | Convert a string to lower case. -- -- > lower "This is A TEST" == "this is a test" -- > lower "" == "" lower :: String -> String lower = map toLower -- | Convert a string to upper case. -- -- > upper "This is A TEST" == "THIS IS A TEST" -- > upper "" == "" upper :: String -> String upper = map toUpper -- | Split the first word off a string. Useful for when starting to parse the beginning -- 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") -- > word1 " keyword\n rest of string" == ("keyword","rest of string") -- > \s -> fst (word1 s) == concat (take 1 $ words s) -- > \s -> words (snd $ word1 s) == drop 1 (words s) word1 :: String -> (String, String) word1 = second trimStart . break isSpace . trimStart -- | Split the first line off a string. -- -- > line1 "" == ("", "") -- > line1 "test" == ("test","") -- > line1 "test\n" == ("test","") -- > line1 "test\nrest" == ("test","rest") -- > line1 "test\nrest\nmore" == ("test","rest\nmore") 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] -- | Invert of 'escapeHTML' (does not do general HTML unescaping) -- -- > \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 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 -- | /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 -- | A combination of 'group' and 'sort', using a part of the value to compare on. -- -- > groupSortOn length ["test","of","sized","item"] == [["of"],["test","item"],["sized"]] groupSortOn :: Ord b => (a -> b) -> [a] -> [[a]] groupSortOn f = map (map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst) . map (f &&& id) -- | A combination of 'group' and 'sort', using a predicate to compare on. -- -- > groupSortBy (compare `on` length) ["test","of","sized","item"] == [["of"],["test","item"],["sized"]] groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]] groupSortBy f = groupBy (\a b -> f a b == EQ) . sortBy f -- | Merge two lists which are assumed to be ordered. -- -- > merge "ace" "bd" == "abcde" -- > \xs ys -> merge (sort xs) (sort ys) == sort (xs ++ ys) merge :: Ord a => [a] -> [a] -> [a] merge = mergeBy compare -- | Like 'merge', but with a custom ordering function. mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] mergeBy f xs [] = xs mergeBy f [] ys = ys mergeBy f (x:xs) (y:ys) | f x y /= GT = x : mergeBy f xs (y:ys) | otherwise = y : mergeBy f (x:xs) ys -- | Replace a subsequence everywhere it occurs. The first argument must -- not be the empty list. -- -- > replace "el" "_" "Hello Bella" == "H_lo B_la" -- > replace "el" "e" "Hello" == "Helo" -- > replace "" "e" "Hello" == undefined -- > \xs ys -> not (null xs) ==> replace xs xs ys == ys replace :: (Partial, Eq a) => [a] -> [a] -> [a] -> [a] replace [] _ _ = error "Extra.replace, first argument cannot be empty" replace 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 [] = [] -- | Break, but from the end. -- -- > breakEnd isLower "youRE" == ("you","RE") -- > breakEnd isLower "youre" == ("youre","") -- > breakEnd isLower "YOURE" == ("","YOURE") -- > \f xs -> breakEnd (not . f) xs == spanEnd f xs breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) breakEnd f = swap . both reverse . break f . reverse -- | Span, but from the end. -- -- > spanEnd isUpper "youRE" == ("you","RE") -- > spanEnd (not . isSpace) "x y z" == ("x y ","z") -- > \f xs -> uncurry (++) (spanEnd f xs) == xs -- > \f xs -> spanEnd f xs == swap (both reverse (span f (reverse xs))) spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) spanEnd f = breakEnd (not . f) -- | A variant of 'words' with a custom test. In particular, -- adjacent separators are discarded, as are leading or trailing separators. -- -- > wordsBy (== ':') "::xyz:abc::123::" == ["xyz","abc","123"] -- > \s -> wordsBy isSpace s == words s wordsBy :: (a -> Bool) -> [a] -> [[a]] wordsBy f s = case dropWhile f s of [] -> [] x:xs -> (x:w) : wordsBy f (drop1 z) where (w,z) = break f xs -- | A variant of 'lines' with a custom test. In particular, -- if there is a trailing separator it will be discarded. -- -- > linesBy (== ':') "::xyz:abc::123::" == ["","","xyz","abc","","123",""] -- > \s -> linesBy (== '\n') s == lines s -- > linesBy (== ';') "my;list;here;" == ["my","list","here"] linesBy :: (a -> Bool) -> [a] -> [[a]] linesBy f [] = [] linesBy f s = cons $ case break f s of (l, s) -> (l,) $ case s of [] -> [] _:s -> linesBy f s where cons ~(h, t) = h : t -- to fix a space leak, see the GHC defn of lines -- | Find the first element of a list for which the operation returns 'Just', along -- with the result of the operation. Like 'find' but useful where the function also -- computes some expensive information that can be reused. Particular useful -- when the function is monadic, see 'firstJustM'. -- -- > firstJust id [Nothing,Just 3] == Just 3 -- > firstJust id [Nothing,Nothing] == Nothing firstJust :: (a -> Maybe b) -> [a] -> Maybe b firstJust f = listToMaybe . mapMaybe f -- | Equivalent to @drop 1@, but likely to be faster and a single lexeme. -- -- > drop1 "" == "" -- > drop1 "test" == "est" -- > \xs -> drop 1 xs == drop1 xs drop1 :: [a] -> [a] drop1 [] = [] 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 -- > \f xs -> mconcatMap f xs == concatMap f xs mconcatMap :: Monoid b => (a -> b) -> [a] -> b mconcatMap f = mconcat . map f -- | Find the first instance of @needle@ in @haystack@. -- 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 match, use 'stripInfix'. -- -- > breakOn "::" "a::b::c" == ("a", "::b::c") -- > breakOn "/" "foobar" == ("foobar", "") -- > \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack breakOn :: Eq a => [a] -> [a] -> ([a], [a]) breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack) breakOn needle [] = ([], []) breakOn needle (x:xs) = first (x:) $ breakOn needle xs -- | Similar to 'breakOn', but searches from the end of the -- string. -- -- The first element of the returned tuple is the prefix of @haystack@ -- up to and including the last match of @needle@. The second is the -- remainder of @haystack@, following the match. -- -- > breakOnEnd "::" "a::b::c" == ("a::b::", "c") breakOnEnd :: Eq a => [a] -> [a] -> ([a], [a]) breakOnEnd needle haystack = both reverse $ swap $ breakOn (reverse needle) (reverse haystack) -- | Break a list into pieces separated by the first -- list argument, consuming the delimiter. An empty delimiter is -- invalid, and will cause an error to be raised. -- -- > splitOn "\r\n" "a\r\nb\r\nd\r\ne" == ["a","b","d","e"] -- > splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""] -- > splitOn "x" "x" == ["",""] -- > splitOn "x" "" == [""] -- > \s x -> s /= "" ==> intercalate s (splitOn s x) == x -- > \c x -> splitOn [c] x == split (==c) x 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 where (a,b) = breakOn needle haystack -- | Splits a list into components delimited by separators, -- where the predicate returns True for a separator element. The -- resulting components do not contain the separators. Two adjacent -- separators result in an empty component in the output. -- -- > split (== 'a') "aabbaca" == ["","","bb","c",""] -- > split (== 'a') "" == [""] -- > split (== ':') "::xyz:abc::123::" == ["","","xyz","abc","","123","",""] -- > split (== ',') "my,list,here" == ["my","list","here"] split :: (a -> Bool) -> [a] -> [[a]] split f [] = [[]] split f (x:xs) | f x = [] : split f xs split f (x:xs) | y:ys <- split f xs = (x:y) : ys -- | 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 -- but only tests the trailing suffix. -- This version usually outperforms 'dropWhileEnd' if the list is short or the test is expensive. -- Note the tests below cover both the prime and non-prime variants. -- -- > dropWhileEnd isSpace "ab cde " == "ab cde" -- > dropWhileEnd' isSpace "ab cde " == "ab cde" -- > last (dropWhileEnd even [undefined,3]) == undefined -- > last (dropWhileEnd' even [undefined,3]) == 3 -- > head (dropWhileEnd even (3:undefined)) == 3 -- > head (dropWhileEnd' even (3:undefined)) == undefined dropWhileEnd' :: (a -> Bool) -> [a] -> [a] dropWhileEnd' p = foldr (\x xs -> if null xs && p x then [] else x : xs) [] -- | 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" -- > stripSuffix "" "baz" == Just "baz" -- > stripSuffix "foo" "quux" == Nothing stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix a b = reverse <$> stripPrefix (reverse a) (reverse b) -- | Return the the string before and after the search string, -- or 'Nothing' if the search string is not present. -- -- Examples: -- -- > stripInfix "::" "a::b::c" == Just ("a", "b::c") -- > stripInfix "/" "foobar" == Nothing stripInfix :: Eq a => [a] -> [a] -> Maybe ([a], [a]) stripInfix needle haystack | Just rest <- stripPrefix needle haystack = Just ([], rest) stripInfix needle [] = Nothing stripInfix needle (x:xs) = first (x:) <$> stripInfix needle xs -- | Similar to 'stripInfix', but searches from the end of the -- string. -- -- > stripInfixEnd "::" "a::b::c" == Just ("a::b", "c") stripInfixEnd :: Eq a => [a] -> [a] -> Maybe ([a], [a]) stripInfixEnd needle haystack = both reverse . swap <$> stripInfix (reverse needle) (reverse haystack) -- | Split a list into chunks of a given size. The last chunk may contain -- fewer than n elements. The chunk size must be positive. -- -- > chunksOf 3 "my test" == ["my ","tes","t"] -- > chunksOf 3 "mytest" == ["myt","est"] -- > chunksOf 8 "" == [] -- > chunksOf 0 "test" == undefined 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 [] = [] -- | /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 -- and consequently runs asymptotically faster. -- -- > nubOrd "this is a test" == "this ae" -- > nubOrd (take 4 ("this" ++ undefined)) == "this" -- > \xs -> nubOrd xs == nub xs nubOrd :: Ord a => [a] -> [a] nubOrd = nubOrdBy compare -- | A version of 'nubOrd' which operates on a portion of the value. -- -- > nubOrdOn length ["a","test","of","this"] == ["a","test","of"] nubOrdOn :: Ord b => (a -> b) -> [a] -> [a] nubOrdOn f = map snd . nubOrdBy (compare `on` fst) . map (f &&& id) -- | A version of 'nubOrd' with a custom predicate. -- -- > nubOrdBy (compare `on` length) ["a","test","of","this"] == ["a","test","of"] nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a] nubOrdBy cmp xs = f E xs where f seen [] = [] f seen (x:xs) | memberRB cmp x seen = f seen xs | otherwise = x : f (insertRB cmp x seen) xs --------------------------------------------------------------------- -- OKASAKI RED BLACK TREE -- Taken from https://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs -- But with the Color = R|B fused into the tree data 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 = case ins s of T_R a z b -> T_B a z b x -> x where 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) EQ -> s memberRB :: (a -> a -> Ordering) -> a -> RB a -> Bool memberRB cmp x E = False 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 -} 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 extra-1.7.4/src/Data/List/NonEmpty/0000755000000000000000000000000013703664774015201 5ustar0000000000000000extra-1.7.4/src/Data/List/NonEmpty/Extra.hs0000644000000000000000000000764413627151405016616 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | 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 ) 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 -- | 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 -- | 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 -- | 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 (==) -- | @nubOrd@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrd'. -- -- > Data.List.NonEmpty.Extra.nubOrd (1 :| [2, 3, 3, 4, 1, 2]) == 1 :| [2, 3, 4] -- > \xs -> Data.List.NonEmpty.Extra.nubOrd xs == Data.List.NonEmpty.Extra.nub xs nubOrd :: Ord a => NonEmpty a -> NonEmpty a nubOrd = nubOrdBy compare -- | @nubOrdBy@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrdBy'. -- -- > Data.List.NonEmpty.Extra.nubOrdBy (compare `on` Data.List.length) ("a" :| ["test","of","this"]) == "a" :| ["test","of"] nubOrdBy :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a nubOrdBy cmp = fromList . List.nubOrdBy cmp . toList -- | @nubOrdOn@ for 'NonEmpty'. Behaves the same as 'Data.List.Extra.nubOrdOn'. -- -- > Data.List.NonEmpty.Extra.nubOrdOn Data.List.length ("a" :| ["test","of","this"]) == "a" :| ["test","of"] nubOrdOn :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty a nubOrdOn f = fromList . List.nubOrdOn f . toList -- | The non-overloaded version of 'union'. unionBy :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a -> NonEmpty a unionBy eq xs ys = fromList $ List.unionBy eq (toList xs) (toList ys) -- | 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) extra-1.7.4/src/Data/IORef/0000755000000000000000000000000013703664774013461 5ustar0000000000000000extra-1.7.4/src/Data/IORef/Extra.hs0000644000000000000000000000204113626156641015066 0ustar0000000000000000 -- | 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, writeIORef', atomicWriteIORef', atomicModifyIORef_, atomicModifyIORef'_ ) where import Data.IORef import Control.Exception -- | Evaluates the value before calling 'writeIORef'. writeIORef' :: IORef a -> a -> IO () writeIORef' ref x = do evaluate x writeIORef ref x -- | Evaluates the value before calling 'atomicWriteIORef'. atomicWriteIORef' :: IORef a -> a -> IO () atomicWriteIORef' ref x = do evaluate x atomicWriteIORef ref x -- | Variant of 'atomicModifyIORef' which ignores the return value atomicModifyIORef_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef_ r f = atomicModifyIORef r $ \v -> (f v, ()) -- | Variant of 'atomicModifyIORef'' which ignores the return value atomicModifyIORef'_ :: IORef a -> (a -> a) -> IO () atomicModifyIORef'_ r f = atomicModifyIORef' r $ \v -> (f v, ()) extra-1.7.4/src/Data/Either/0000755000000000000000000000000013703664774013735 5ustar0000000000000000extra-1.7.4/src/Data/Either/Extra.hs0000644000000000000000000000641213435010226015332 0ustar0000000000000000{-# 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, fromLeft, fromRight, fromEither, fromLeft', fromRight', eitherToMaybe, maybeToEither, mapLeft, mapRight, ) where import Data.Either import Partial #if __GLASGOW_HASKELL__ < 801 -- | Return the contents of a 'Left'-value or a default value otherwise. -- -- > fromLeft 1 (Left 3) == 3 -- > fromLeft 1 (Right "foo") == 1 fromLeft :: a -> Either a b -> a fromLeft _ (Left a) = a fromLeft a _ = a -- | Return the contents of a 'Right'-value or a default value otherwise. -- -- > fromRight 1 (Right 3) == 3 -- > fromRight 1 (Left "foo") == 1 fromRight :: b -> Either a b -> b fromRight _ (Right b) = b fromRight b _ = b #endif -- | The 'fromLeft'' function extracts the element out of a 'Left' and -- throws an error if its argument is 'Right'. -- Much like 'fromJust', using this function in polished code is usually a bad idea. -- -- > \x -> fromLeft' (Left x) == x -- > \x -> fromLeft' (Right x) == undefined fromLeft' :: Partial => Either l r -> l fromLeft' (Left x) = x fromLeft' _ = error "fromLeft', given a Right" -- | The 'fromRight'' function extracts the element out of a 'Right' and -- throws an error if its argument is 'Left'. -- Much like 'fromJust', using this function in polished code is usually a bad idea. -- -- > \x -> fromRight' (Right x) == x -- > \x -> fromRight' (Left x) == undefined fromRight' :: Partial => Either l r -> r fromRight' (Right x) = x fromRight' _ = error "fromRight', given a Left" -- | Pull the value out of an 'Either' where both alternatives -- have the same type. -- -- > \x -> fromEither (Left x ) == x -- > \x -> fromEither (Right x) == x fromEither :: Either a a -> a fromEither = either id id -- | Given a 'Maybe', convert it to an 'Either', providing a suitable -- value for the 'Left' should the value be 'Nothing'. -- -- > \a b -> maybeToEither a (Just b) == Right b -- > \a -> maybeToEither a Nothing == Left a maybeToEither :: a -> Maybe b -> Either a b maybeToEither a (Just b) = Right b maybeToEither a Nothing = Left a -- | Given an 'Either', convert it to a 'Maybe', where 'Left' becomes 'Nothing'. -- -- > \x -> eitherToMaybe (Left x) == Nothing -- > \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 extra-1.7.4/src/Control/0000755000000000000000000000000013703664774013264 5ustar0000000000000000extra-1.7.4/src/Control/Monad/0000755000000000000000000000000013703664774014322 5ustar0000000000000000extra-1.7.4/src/Control/Monad/Extra.hs0000644000000000000000000002204513703664537015741 0ustar0000000000000000{-# 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 . module Control.Monad.Extra( module Control.Monad, whenJust, whenJustM, whenMaybe, whenMaybeM, unit, maybeM, fromMaybeM, eitherM, -- * Loops 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 import Prelude -- General utilities -- | Perform some operation on 'Just', given the field inside the 'Just'. -- -- > whenJust Nothing print == pure () -- > whenJust (Just 1) print == print 1 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust mg f = maybe (pure ()) f mg -- | Like 'whenJust', but where the test can be monadic. whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () -- Can't reuse whenMaybe on GHC 7.8 or lower because Monad does not imply Applicative whenJustM mg f = maybeM (pure ()) f mg -- | Like 'when', but return either 'Nothing' if the predicate was 'False', -- of 'Just' with the result of the computation. -- -- > whenMaybe True (print 1) == fmap Just (print 1) -- > whenMaybe False (print 1) == pure Nothing 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. 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 unit :: m () -> m () unit = id -- | Monadic generalisation of 'maybe'. 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'. fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a fromMaybeM n x = maybeM n pure x -- | Monadic generalisation of 'either'. eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c eitherM l r x = either l r =<< x -- | 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 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. 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 partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) partitionM f [] = pure ([], []) partitionM f (x:xs) = do res <- f x (as,bs) <- partitionM f xs 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 (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. concatForM :: Monad m => [a] -> (a -> m [b]) -> m [b] concatForM = flip concatMapM -- | A version of 'mconcatMap' that works with a monadic predicate. 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 (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" 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. 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 -> pure v -- | Keep running an operation until it becomes 'False'. As an example: -- -- @ -- whileM $ do sleep 0.1; notM $ doesFileExist "foo.txt" -- readFile "foo.txt" -- @ -- -- If you need some state persisted between each test, use 'loopM'. 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. 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. 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. whenM :: Monad m => m Bool -> m () -> m () whenM b t = ifM b t (pure ()) -- | Like 'unless', but where the test can be monadic. unlessM :: Monad m => m Bool -> m () -> m () unlessM b f = ifM b (pure ()) f -- | Like @if@, but where the test can be monadic. 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. notM :: Functor m => m Bool -> m Bool notM = fmap not -- | The lazy '||' operator lifted to a monad. If the first -- argument evaluates to 'True' the second argument will not -- be evaluated. -- -- > Just True ||^ undefined == Just True -- > Just False ||^ Just True == Just True -- > Just False ||^ Just False == Just False (||^) :: Monad m => m Bool -> m Bool -> m Bool (||^) 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 -- be evaluated. -- -- > Just False &&^ undefined == Just False -- > Just True &&^ Just True == Just True -- > Just True &&^ Just False == Just False (&&^) :: Monad m => m Bool -> m Bool -> m Bool (&&^) a b = ifM a b (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) anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool 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) allM :: Monad m => (a -> m Bool) -> [a] -> m Bool 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) orM :: Monad m => [m Bool] -> m Bool orM = anyM id -- | A version of 'and' lifted to a monad. Retains the short-circuiting behaviour. -- -- > andM [Just True,Just False,undefined] == Just False -- > andM [Just True,Just True ,undefined] == undefined -- > \xs -> Just (and xs) == andM (map Just xs) andM :: Monad m => [m Bool] -> m Bool andM = allM id -- Searching -- | Like 'find', but where the test can be monadic. -- -- > findM (Just . isUpper) "teST" == Just (Just 'S') -- > findM (Just . isUpper) "test" == Just Nothing -- > findM (Just . const True) ["x",undefined] == Just (Just "x") findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) -- | Like 'findM', but also allows you to compute some additional information in the predicate. firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) firstJustM p [] = pure Nothing firstJustM p (x:xs) = maybeM (firstJustM p xs) (pure . Just) (p x) extra-1.7.4/src/Control/Exception/0000755000000000000000000000000013703664774015222 5ustar0000000000000000extra-1.7.4/src/Control/Exception/Extra.hs0000644000000000000000000001234413665300016016624 0ustar0000000000000000{-# 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, -- * Exception catching/ignoring ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, 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" == 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 -> pure "" Right [] -> pure [] Right (x:xs) -> (x:) <$> stringException xs -- | Show a value, but if the result contains exceptions, produce -- @\@. Defined as @'stringException' . show@. -- Particularly useful for printing exceptions to users, remembering that exceptions -- can themselves contain undefined values. showException :: Show e => e -> IO String showException = stringException . show #if __GLASGOW_HASKELL__ < 800 -- | A variant of 'error' that does not produce a stack trace. errorWithoutStackTrace :: String -> a errorWithoutStackTrace = error #endif -- | Ignore any exceptions thrown by the action. -- -- > ignore (print 1) == print 1 -- > ignore (fail "die") == pure () ignore :: IO () -> IO () ignore = void . try_ -- | An 'IO' action that when evaluated calls 'error', in the 'IO' monad. -- Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception with a call stack. -- -- > catch (errorIO "Hello") (\(ErrorCall x) -> 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 -- | 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. -- -- > retry 1 (print "x") == print "x" -- > retry 3 (fail "die") == fail "die" retry :: Int -> IO a -> IO a retry i x | i <= 0 = error "Control.Exception.Extra.retry: count must be 1 or more" retry i x = retryBool (\(e :: SomeException) -> True) i x -- | Retry an operation at most /n/ times (/n/ must be positive), while the exception value and type match a predicate. -- If the operation fails the /n/th time it will throw that final exception. retryBool :: Exception e => (e -> Bool) -> Int -> IO a -> IO a retryBool p i x | i <= 0 = error "Control.Exception.Extra.retryBool: count must be 1 or more" retryBool p 1 x = x retryBool p i x = do res <- tryBool p x case res of Left _ -> retryBool p (i-1) x Right v -> pure v -- | A version of 'catch' without the 'Exception' context, restricted to 'SomeException', -- so catches all exceptions. catch_ :: IO a -> (SomeException -> IO a) -> IO a catch_ = Control.Exception.catch -- | Like 'catch_' but for 'catchJust' catchJust_ :: (SomeException -> Maybe b) -> IO a -> (b -> IO a) -> IO a catchJust_ = catchJust -- | Like 'catch_' but for 'handle' handle_ :: (SomeException -> IO a) -> IO a -> IO a handle_ = handle -- | Like 'catch_' but for 'handleJust' handleJust_ :: (SomeException -> Maybe b) -> (b -> IO a) -> IO a -> IO a handleJust_ = handleJust -- | Like 'catch_' but for 'try' try_ :: IO a -> IO (Either SomeException a) try_ = try -- | Like 'catch_' but for 'tryJust' tryJust_ :: (SomeException -> Maybe b) -> IO a -> IO (Either b a) tryJust_ = tryJust -- | Catch an exception if the predicate passes, then call the handler with the original exception. -- As an example: -- -- @ -- 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 -- | Like 'catchBool' but for 'handle'. handleBool :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a handleBool f a b = handleJust (bool f) a b -- | Like 'catchBool' but for 'try'. tryBool :: Exception e => (e -> Bool) -> IO a -> IO (Either e a) tryBool f a = tryJust (bool f) a bool :: (e -> Bool) -> (e -> Maybe e) bool f x = if f x then Just x else Nothing extra-1.7.4/src/Control/Concurrent/0000755000000000000000000000000013703664774015406 5ustar0000000000000000extra-1.7.4/src/Control/Concurrent/Extra.hs0000644000000000000000000001640213703664537017025 0ustar0000000000000000{-# 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. -- If you need elaborate relationships between threads -- see the package. module Control.Concurrent.Extra( module Control.Concurrent, withNumCapabilities, once, onceFork, -- * Lock Lock, newLock, withLock, withLockTry, -- * Var Var, newVar, readVar, writeVar, modifyVar, modifyVar_, withVar, -- * Barrier Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, ) where import Control.Concurrent import Control.Exception.Extra import Control.Monad.Extra import Data.Maybe import Data.Either.Extra import Data.Functor import Prelude -- | On GHC 7.6 and above with the @-threaded@ flag, brackets a call to 'setNumCapabilities'. -- On lower versions (which lack 'setNumCapabilities') this function just runs the argument action. withNumCapabilities :: Int -> IO a -> IO a withNumCapabilities new act | rtsSupportsBoundThreads = do old <- getNumCapabilities if old == new then act else bracket_ (setNumCapabilities new) (setNumCapabilities old) act withNumCapabilities _ act = act -- | 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) == 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 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 pure $ (OnceRunning b,) $ do res <- try_ $ unmask act signalBarrier b res modifyVar_ var $ \_ -> pure $ OnceDone res run res data Once a = OncePending | OnceRunning (Barrier a) | OnceDone a -- | Like 'once', but immediately starts running the computation on a background thread. -- -- > \(x :: IO Int) -> join (onceFork x) == x -- > \(x :: IO Int) -> (do a <- onceFork x; a; a) == x onceFork :: IO a -> IO (IO a) onceFork act = do bar <- newBarrier forkFinally act $ signalBarrier bar pure $ eitherM throwIO pure $ waitBarrier bar --------------------------------------------------------------------- -- LOCK -- | 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' 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, -- but rare, that a withLock contains a withLock inside it - but if so, -- watch out for deadlocks. newtype Lock = Lock (MVar ()) -- | Create a new 'Lock'. newLock :: IO Lock newLock = Lock <$> newMVar () -- | Perform some operation while holding 'Lock'. Will prevent all other -- operations from using the 'Lock' while the action is ongoing. withLock :: Lock -> IO a -> IO a withLock (Lock x) = withMVar x . const -- | Like 'withLock' but will never block. If the operation cannot be executed -- immediately it will return 'Nothing'. withLockTry :: Lock -> IO a -> IO (Maybe a) withLockTry (Lock m) act = bracket (tryTakeMVar m) (\v -> when (isJust v) $ putMVar m ()) (\v -> if isJust v then fmap Just act else pure Nothing) --------------------------------------------------------------------- -- VAR -- | 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) -- @ -- -- 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 -- 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'. newtype Var a = Var (MVar a) -- | Create a new 'Var' with a value. newVar :: a -> IO (Var a) newVar = fmap Var . newMVar -- | Read the current value of the 'Var'. readVar :: Var a -> IO a readVar (Var x) = readMVar x -- | Write a value to become the new value of 'Var'. 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 -- | Modify a 'Var', a restricted version of 'modifyVar'. modifyVar_ :: Var a -> (a -> IO a) -> IO () modifyVar_ (Var x) f = modifyMVar_ x f -- | Perform some operation using the value in the 'Var', -- a restricted version of 'modifyVar'. withVar :: Var a -> (a -> IO b) -> IO b withVar (Var x) f = withMVar x f --------------------------------------------------------------------- -- BARRIER -- | Starts out empty, then is filled exactly once. As an example: -- -- @ -- bar <- 'newBarrier' -- forkIO $ do ...; val <- ...; 'signalBarrier' bar val -- print =<< 'waitBarrier' bar -- @ -- -- Here we create a barrier which will contain some computed value. -- A thread is forked to fill the barrier, while the main thread waits -- 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 (MVar a) -- | Create a new 'Barrier'. newBarrier :: IO (Barrier a) newBarrier = Barrier <$> newEmptyMVar -- | Write a value into the Barrier, releasing anyone at 'waitBarrier'. -- Any subsequent attempts to signal the 'Barrier' will throw an exception. signalBarrier :: Partial => Barrier a -> a -> IO () signalBarrier (Barrier var) v = 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) = 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) = tryReadMVar bar