extra-1.4.10/0000755000000000000000000000000012730320114011077 5ustar0000000000000000extra-1.4.10/Setup.hs0000644000000000000000000000005612730320114012534 0ustar0000000000000000import Distribution.Simple main = defaultMain extra-1.4.10/README.md0000644000000000000000000000533512730320114012364 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/lts?label=Stackage)](https://www.stackage.org/package/extra) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/extra.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/extra) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/extra.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/extra) A library of extra functions for the standard Haskell libraries. Most functions are simple additions, filling out missing functionality. A few functions are available in later versions of GHC, but this package makes them available back to GHC 7.2. A few examples: * `Control.Monad.Extra.concatMapM` provides a monadic version of `concatMap`, in the same way that `mapM` is a monadic version of `map`. * `Data.Tuple.Extra.fst3` provides a function to get the first element of a triple. * `Control.Exception.Extra.retry` provides a function that retries an `IO` action a number of times. * `System.Environment.Extra.lookupEnv` is a function available in GHC 7.6 and above. On GHC 7.6 and above this package reexports the version from `System.Environment` while on GHC 7.4 and below it defines an equivalent version. 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 The following GHC versions correspond to the following base library versions: * base 4.9 == GHC 8.0 * base 4.8 == GHC 7.10 * base 4.7 == GHC 7.8 * base 4.6 == GHC 7.6 * base 4.5 == GHC 7.4 * base 4.4 == GHC 7.2 extra-1.4.10/LICENSE0000644000000000000000000000276412730320114012115 0ustar0000000000000000Copyright Neil Mitchell 2014-2016. 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.4.10/Generate.hs0000644000000000000000000000625212730320114013172 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.Monad.Extra import Control.Applicative import System.FilePath import System.Directory import Data.Char import Data.Maybe import Prelude main :: IO () main = do src <- readFile "extra.cabal" mods <- return $ 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 return (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("] ++ concat [ [" -- * " ++ mod ," -- | Extra functions available in @" ++ show mod ++ "@." ," " ++ unwords (map (++",") funs)] | (mod,funs,_) <- ifaces] ++ [" ) where" ,""] ++ ["import " ++ x | x <- mods] 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" ,"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 old <- ifM (doesFileExist file) (Just <$> readFileBinary' file) (return Nothing) when (Just x /= old) $ writeFileBinary file x 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.4.10/extra.cabal0000644000000000000000000000470512730320114013214 0ustar0000000000000000cabal-version: >= 1.10 build-type: Simple name: extra version: 1.4.10 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell copyright: Neil Mitchell 2014-2016 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.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.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.4 && < 5, directory, filepath, process, time if !os(windows) build-depends: unix exposed-modules: Extra Control.Concurrent.Extra Control.Exception.Extra Control.Monad.Extra Data.Either.Extra Data.IORef.Extra Data.List.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 test-suite extra-test type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base == 4.*, directory, filepath, extra, time, QuickCheck if !os(windows) build-depends: unix hs-source-dirs: test ghc-options: -main-is Test -threaded -with-rtsopts=-N4 main-is: Test.hs other-modules: TestCustom TestGen TestUtil extra-1.4.10/CHANGES.txt0000644000000000000000000000455412730320114012720 0ustar0000000000000000Changelog for Extra 1.4.10 Add Data.Typeable.Extra containing typeRep, Proxy, (:~:) 1.4.9 Add line1 1.4.8 Add displayException 1.4.7 #21, add concatForM 1.4.6 #11, add maybeM and eitherM 1.4.5 #17, change fileEq on files that do not exist to be an error 1.4.4 #14, add mconcatMap and mconcatMapM #16, add fileEq #15, add isMac 1.4.3 Add Data.Version.Extra 1.4.2 Make concatMapM/mapMaybeM faster 1.4.1 Make temp file functions workaround GHC bug #10731 Add retryBool 1.4 Add stripInfix and stripInfixEnd 1.3.1 #9, support directory-1.2.3 1.3 Add whenJustM Add errorIO 1.2 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 #7, add nubOrd, nubOrdOn, nubOrdBy #6, add groupSortOn and groupSortBy #5, add splitAtEnd 1.0.1 Make listFilesAvoid drop trailing path separators before testing #3, add a constraint base >= 4.4 1.0 No changes 0.8 Fix a bug in writeFileEncoding/writeFileUTF8 0.7 Fix for missing case in withNumCapabilities 0.6 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 Use uncons from GHC 7.9 and above 0.5 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 Remove all but the extractors on triples Remove groupSortOn Remove dropAround 0.3.2 Remove use of ===, allows older QuickCheck versions 0.3.1 Fix a bug in breakEnd/spanEnd 0.3 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 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 Initial version, still unstable extra-1.4.10/test/0000755000000000000000000000000012730320114012056 5ustar0000000000000000extra-1.4.10/test/TestUtil.hs0000644000000000000000000000550312730320114014172 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, CPP, FlexibleInstances #-} module TestUtil(runTests, testGen, testRaw, erroneous, erroneousIO, (====), module X) where import Test.QuickCheck import Test.QuickCheck.Test import Control.Exception.Extra import Data.Either.Extra import System.IO.Extra import Data.Version.Extra import Data.IORef import System.IO.Unsafe import Data.Time.Clock import Data.Time.Calendar import Text.Show.Functions() import Extra as X import Control.Applicative as X import Control.Monad as X import Data.Function as X import Data.List as X import Data.Char as X import Data.Monoid as X import Data.Tuple as X import Data.Typeable as X import Data.Version as X import System.Directory as X import System.FilePath as X import System.Info as X import Control.Exception as X import Test.QuickCheck 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 unless (isSuccess r) $ error "Test failed" testRaw :: String -> IO () -> IO () testRaw msg test = do putStrLn msg test modifyIORef testCount (+1) erroneous :: a -> Bool erroneous x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate x erroneousIO :: IO a -> Bool erroneousIO x = unsafePerformIO $ fmap isLeft $ try_ $ evaluate =<< x (====) :: (Show a, Eq a) => a -> a -> Bool a ==== b = if a == b then True else error $ "Not equal!\n" ++ show a ++ "\n" ++ show b #if __GLASGOW_HASKELL__ < 707 instance Eq ErrorCall where ErrorCall x == ErrorCall y = x == y #endif runTests :: IO () -> IO () runTests t = do writeIORef testCount 0 t n <- readIORef testCount putStrLn $ "Success (" ++ show n ++ " tests)" instance Testable () where property = property . (`seq` True) exhaustive _ = True instance Testable a => Testable (IO a) where property = property . unsafePerformIO exhaustive = exhaustive . unsafePerformIO instance Eq a => Eq (IO a) where a == b = unsafePerformIO $ do a <- try_ $ captureOutput a b <- try_ $ captureOutput b return $ 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 return $ do whenJust prnt print whenJust thrw (fail . show) return res instance Eq SomeException where a == b = show a == show b instance Arbitrary UTCTime where arbitrary = liftM2 UTCTime arbitrary arbitrary instance Arbitrary Day where arbitrary = fmap ModifiedJulianDay arbitrary instance Arbitrary DiffTime where arbitrary = fmap realToFrac $ choose (0 :: Double, 86401) instance Arbitrary Version where arbitrary = makeVersion . map abs <$> listOf1 arbitrary extra-1.4.10/test/TestGen.hs0000644000000000000000000006330612730320114013773 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 default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () tests = do let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2 testGen "\\(x :: IO Int) -> void (once x) == return ()" $ \(x :: IO Int) -> void (once x) == return () testGen "\\(x :: IO Int) -> join (once x) == x" $ \(x :: IO Int) -> join (once x) == x testGen "\\(x :: IO Int) -> (do y <- once x; y; y) == x" $ \(x :: IO Int) -> (do y <- once x; y; y) == x testGen "\\(x :: IO Int) -> (do y <- once x; y ||| y) == x" $ \(x :: IO Int) -> (do y <- once x; y ||| y) == x testGen "\\(x :: IO Int) -> join (onceFork x) == x" $ \(x :: IO Int) -> join (onceFork x) == x testGen "\\(x :: IO Int) -> (do a <- onceFork x; a; a) == x" $ \(x :: IO Int) -> (do a <- onceFork x; a; a) == x testGen "stringException \"test\" == return \"test\"" $ stringException "test" == return "test" testGen "stringException (\"test\" ++ undefined) == return \"test\"" $ stringException ("test" ++ undefined) == return "test" testGen "stringException (\"test\" ++ undefined ++ \"hello\") == return \"test\"" $ stringException ("test" ++ undefined ++ "hello") == return "test" testGen "stringException ['t','e','s','t',undefined] == return \"test\"" $ stringException ['t','e','s','t',undefined] == return "test" testGen "ignore (print 1) == print 1" $ ignore (print 1) == print 1 testGen "ignore (fail \"die\") == return ()" $ ignore (fail "die") == return () testGen "try (errorIO \"Hello\") == return (Left (ErrorCall \"Hello\"))" $ try (errorIO "Hello") == return (Left (ErrorCall "Hello")) testGen "retry 1 (print \"x\") == print \"x\"" $ retry 1 (print "x") == print "x" testGen "retry 3 (fail \"die\") == fail \"die\"" $ retry 3 (fail "die") == fail "die" testGen "whenJust Nothing print == return ()" $ whenJust Nothing print == return () testGen "whenJust (Just 1) print == print 1" $ whenJust (Just 1) print == print 1 testGen "\\(x :: Maybe ()) -> unit x == x" $ \(x :: Maybe ()) -> unit x == x 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 "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 "\\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 "\\xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs" $ \xs -> repeatedly (splitAt 3) xs == chunksOf 3 xs testGen "\\xs -> repeatedly word1 (trim xs) == words xs" $ \xs -> repeatedly word1 (trim xs) == words xs testGen "\\xs -> repeatedly line1 xs == lines xs" $ \xs -> repeatedly line1 xs == lines xs testGen "for [1,2,3] (+1) == [2,3,4]" $ for [1,2,3] (+1) == [2,3,4] testGen "disjoint [1,2,3] [4,5] == True" $ disjoint [1,2,3] [4,5] == True testGen "disjoint [1,2,3] [4,1] == False" $ disjoint [1,2,3] [4,1] == False testGen "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 "list 1 (\\v _ -> v - 2) [5,6,7] == 3" $ list 1 (\v _ -> v - 2) [5,6,7] == 3 testGen "list 1 (\\v _ -> v - 2) [] == 1" $ list 1 (\v _ -> v - 2) [] == 1 testGen "\\nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs" $ \nil cons xs -> maybe nil (uncurry cons) (uncons xs) == list nil cons xs testGen "uncons \"test\" == Just ('t',\"est\")" $ uncons "test" == Just ('t',"est") testGen "uncons \"\" == Nothing" $ uncons "" == Nothing testGen "\\xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs)" $ \xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs) testGen "unsnoc \"test\" == Just (\"tes\",'t')" $ unsnoc "test" == Just ("tes",'t') testGen "unsnoc \"\" == Nothing" $ unsnoc "" == Nothing testGen "\\xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs)" $ \xs -> unsnoc xs == if null xs then Nothing else Just (init xs, last xs) 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 "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 "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 "sortOn fst [(3,\"z\"),(1,\"\"),(3,\"a\")] == [(1,\"\"),(3,\"z\"),(3,\"a\")]" $ sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")] testGen "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 "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 "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 "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 "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 "(succ *** reverse) (1,\"test\") == (2,\"tset\")" $ (succ *** reverse) (1,"test") == (2,"tset") testGen "(succ &&& pred) 1 == (2,0)" $ (succ &&& pred) 1 == (2,0) testGen "dupe 12 == (12, 12)" $ dupe 12 == (12, 12) testGen "both succ (1,2) == (2,3)" $ both succ (1,2) == (2,3) testGen "typeRep (Proxy :: Proxy Int) == typeOf (1 :: Int)" $ typeRep (Proxy :: Proxy Int) == typeOf (1 :: Int) testGen "showVersion (makeVersion [1,2,3]) == \"1.2.3\"" $ showVersion (makeVersion [1,2,3]) == "1.2.3" testGen "\\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; return $ 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 listFiles [\"bar.txt\",\"foo/baz.txt\",\"zoo\"] [\"bar.txt\",\"zoo\"]" $ listTest listFiles ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","zoo"] testGen "listTest listFilesRecursive [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"] [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"]" $ listTest listFilesRecursive ["bar.txt","zoo","foo" "baz.txt"] ["bar.txt","zoo","foo" "baz.txt"] testGen "listTest (listFilesInside $ return . not . isPrefixOf \".\" . takeFileName) [\"bar.txt\",\"foo\" \"baz.txt\",\".foo\" \"baz2.txt\", \"zoo\"] [\"bar.txt\",\"zoo\",\"foo\" \"baz.txt\"]" $ listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName) ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] testGen "listTest (listFilesInside $ const $ return False) [\"bar.txt\"] []" $ listTest (listFilesInside $ const $ return False) ["bar.txt"] [] testGen "isWindows == (os == \"mingw32\")" $ isWindows == (os == "mingw32") testGen "\\(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \\file -> do writeFile file s; readFile' file" $ \(filter isHexDigit -> s) -> fmap (== s) $ withTempFile $ \file -> do writeFile file s; readFile' file testGen "\\s -> withTempFile $ \\file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file" $ \s -> withTempFile $ \file -> do writeFileUTF8 file s; fmap (== s) $ readFileUTF8' file testGen "\\s -> withTempFile $ \\file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file" $ \s -> withTempFile $ \file -> do writeFileBinary file s; fmap (== s) $ readFileBinary' file testGen "captureOutput (print 1) == return (\"1\\n\",())" $ captureOutput (print 1) == return ("1\n",()) testGen "withTempFile doesFileExist == return True" $ withTempFile doesFileExist == return True testGen "(doesFileExist =<< withTempFile return) == return False" $ (doesFileExist =<< withTempFile return) == return False testGen "withTempFile readFile' == return \"\"" $ withTempFile readFile' == return "" testGen "withTempDir doesDirectoryExist == return True" $ withTempDir doesDirectoryExist == return True testGen "(doesDirectoryExist =<< withTempDir return) == return False" $ (doesDirectoryExist =<< withTempDir return) == return False testGen "withTempDir listFiles == return []" $ withTempDir listFiles == return [] testGen "fileEq \"does_not_exist1\" \"does_not_exist2\" == undefined" $ erroneousIO $ fileEq "does_not_exist1" "does_not_exist2" testGen "fileEq \"does_not_exist\" \"does_not_exist\" == undefined" $ erroneousIO $ fileEq "does_not_exist" "does_not_exist" testGen "withTempFile $ \\f1 -> fileEq \"does_not_exist\" f1 == undefined" $ erroneousIO $ withTempFile $ \f1 -> fileEq "does_not_exist" f1 testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> fileEq f1 f2" $ withTempFile $ \f1 -> withTempFile $ \f2 -> fileEq f1 f2 testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> writeFile f1 \"a\" >> writeFile f2 \"a\" >> fileEq f1 f2" $ withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "a" >> fileEq f1 f2 testGen "withTempFile $ \\f1 -> withTempFile $ \\f2 -> writeFile f1 \"a\" >> writeFile f2 \"b\" >> notM (fileEq f1 f2)" $ withTempFile $ \f1 -> withTempFile $ \f2 -> writeFile f1 "a" >> writeFile f2 "b" >> notM (fileEq f1 f2) testGen "fmap (round . fst) (duration $ sleep 1) == return 1" $ fmap (round . fst) (duration $ sleep 1) == return 1 testGen "timeout (-3) (print 1) == return Nothing" $ timeout (-3) (print 1) == return Nothing testGen "timeout 0.1 (print 1) == fmap Just (print 1)" $ timeout 0.1 (print 1) == fmap Just (print 1) testGen "do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1" $ do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1 testGen "timeout 0.1 (sleep 2 >> print 1) == return Nothing" $ timeout 0.1 (sleep 2 >> print 1) == return Nothing testGen "\\a b -> a > b ==> subtractTime a b > 0" $ \a b -> a > b ==> subtractTime a b > 0 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 <- offsetTimeIncrease; xs <- replicateM 10 f; return $ xs == sort xs" $ do f <- offsetTimeIncrease; xs <- replicateM 10 f; return $ xs == sort xs extra-1.4.10/test/TestCustom.hs0000644000000000000000000000161712730320114014531 0ustar0000000000000000 module TestCustom(testCustom) where import Control.Concurrent.Extra import Control.Monad import System.IO.Extra import Data.IORef import TestUtil import Extra as X testCustom :: IO () testCustom = do -- check that Extra really does export these things testGen "Extra export" $ Proxy == (X.Proxy :: Proxy ()) testRaw "withTempFile" $ do xs <- replicateM 4 $ onceFork $ do replicateM_ 100 $ withTempFile (const $ return ()) putChar '.' sequence_ xs putStrLn "done" testRaw "withTempDir" $ do xs <- replicateM 4 $ onceFork $ do replicateM_ 100 $ withTempDir (const $ return ()) 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 extra-1.4.10/test/Test.hs0000644000000000000000000000047212730320114013334 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.4.10/src/0000755000000000000000000000000012730320114011666 5ustar0000000000000000extra-1.4.10/src/Extra.hs0000644000000000000000000001024412730320114013306 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( -- * Control.Concurrent.Extra -- | Extra functions available in @"Control.Concurrent.Extra"@. getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, once, onceFork, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, -- * Control.Exception.Extra -- | Extra functions available in @"Control.Exception.Extra"@. retry, retryBool, showException, stringException, errorIO, displayException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, -- * Control.Monad.Extra -- | Extra functions available in @"Control.Monad.Extra"@. whenJust, whenJustM, unit, maybeM, eitherM, loopM, whileM, partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, -- * Data.Either.Extra -- | Extra functions available in @"Data.Either.Extra"@. isLeft, isRight, fromLeft, fromRight, fromEither, -- * Data.IORef.Extra -- | Extra functions available in @"Data.IORef.Extra"@. modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef', -- * Data.List.Extra -- | Extra functions available in @"Data.List.Extra"@. lower, upper, trim, trimStart, trimEnd, word1, line1, dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, replace, merge, mergeBy, -- * Data.Tuple.Extra -- | Extra functions available in @"Data.Tuple.Extra"@. first, second, (***), (&&&), dupe, both, fst3, snd3, thd3, -- * Data.Typeable.Extra -- | Extra functions available in @"Data.Typeable.Extra"@. typeRep, (:~:)(..), Proxy(..), -- * Data.Version.Extra -- | Extra functions available in @"Data.Version.Extra"@. makeVersion, readVersion, -- * Numeric.Extra -- | Extra functions available in @"Numeric.Extra"@. showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat, -- * System.Directory.Extra -- | Extra functions available in @"System.Directory.Extra"@. withCurrentDirectory, createDirectoryPrivate, listContents, listFiles, listFilesInside, listFilesRecursive, -- * System.Environment.Extra -- | Extra functions available in @"System.Environment.Extra"@. getExecutablePath, lookupEnv, -- * System.Info.Extra -- | Extra functions available in @"System.Info.Extra"@. isWindows, isMac, -- * System.IO.Extra -- | Extra functions available in @"System.IO.Extra"@. captureOutput, withBuffering, readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, newTempFile, newTempDir, fileEq, -- * System.Process.Extra -- | Extra functions available in @"System.Process.Extra"@. system_, systemOutput, systemOutput_, -- * System.Time.Extra -- | Extra functions available in @"System.Time.Extra"@. Seconds, sleep, timeout, subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration, ) 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.Tuple.Extra import Data.Typeable.Extra import Data.Version.Extra import Numeric.Extra import System.Directory.Extra import System.Environment.Extra import System.Info.Extra import System.IO.Extra import System.Process.Extra import System.Time.Extra extra-1.4.10/src/System/0000755000000000000000000000000012730320114013152 5ustar0000000000000000extra-1.4.10/src/System/Time/0000755000000000000000000000000012730320114014050 5ustar0000000000000000extra-1.4.10/src/System/Time/Extra.hs0000644000000000000000000001020612730320114015466 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, subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration ) where import Control.Concurrent import Data.Time.Clock import Numeric.Extra import Data.IORef 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) == return 1 sleep :: Seconds -> IO () sleep = loopM $ \s -> -- important to handle both overflow and underflow vs Int if s < 0 then return $ Right () else if s > 2000 then do threadDelay 2000000000 -- 2000 * 1e6 return $ Left $ s - 2000 else do threadDelay $ ceiling $ s * 1000000 return $ 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) == return Nothing -- > timeout 0.1 (print 1) == fmap Just (print 1) -- > do (t, _) <- duration $ timeout 0.1 $ sleep 1000; print t; return $ t < 1 -- > timeout 0.1 (sleep 2 >> print 1) == return Nothing timeout :: Seconds -> IO a -> IO (Maybe a) -- Copied from GHC with a few tweaks. timeout n f | n <= 0 = return Nothing | otherwise = do pid <- myThreadId ex <- fmap Timeout newUnique handleBool (== ex) (const $ return Nothing) (bracket (forkIOWithUnmask $ \unmask -> unmask $ sleep n >> throwTo pid ex) (killThread) (\_ -> fmap Just f)) -- | Calculate the difference between two times in seconds. -- Usually the first time will be the end of an event, and the -- second time will be the beginning. -- -- > \a b -> a > b ==> subtractTime a b > 0 subtractTime :: UTCTime -> UTCTime -> Seconds subtractTime end start = fromRational $ toRational $ end `diffUTCTime` start -- | Show a number of seconds, typically a duration, in a suitable manner with -- responable precision for a human. -- -- > 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. Values will usually increase, unless the system clock is updated -- (if you need the guarantee, see 'offsetTimeIncrease'). offsetTime :: IO (IO Seconds) offsetTime = do start <- getCurrentTime return $ do end <- getCurrentTime return $ end `subtractTime` start -- | Like 'offsetTime', but results will never decrease (though they may stay the same). -- -- > do f <- offsetTimeIncrease; xs <- replicateM 10 f; return $ xs == sort xs offsetTimeIncrease :: IO (IO Seconds) offsetTimeIncrease = do t <- offsetTime ref <- newIORef 0 return $ do t <- t atomicModifyIORef ref $ \o -> let m = max t o in m `seq` (m, m) -- | Record how long a computation takes in 'Seconds'. duration :: IO a -> IO (Seconds, a) duration act = do time <- offsetTime res <- act time <- time return (time, res) extra-1.4.10/src/System/Process/0000755000000000000000000000000012730320114014570 5ustar0000000000000000extra-1.4.10/src/System/Process/Extra.hs0000644000000000000000000000257512730320114016220 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- | 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 -- | 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 fmap (exit,) $ readFile' file -- | A version of 'system' that throws an error if the 'ExitCode' is not 'ExitSuccess'. system_ :: 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_ :: String -> IO String systemOutput_ x = do (res,out) <- systemOutput x when (res /= ExitSuccess) $ error $ "Failed when running system command: " ++ x return out extra-1.4.10/src/System/IO/0000755000000000000000000000000012730320114013461 5ustar0000000000000000extra-1.4.10/src/System/IO/Extra.hs0000644000000000000000000002135512730320114015106 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, -- * 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 return 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. -- -- > \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) == return ("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 return (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 = do file <- create del <- once $ ignore $ removeFile file return (file, del) where create = do tmpdir <- getTemporaryDirectory val <- tempUnique (file, h) <- retryBool (\(_ :: IOError) -> True) 5 $ openTempFile tmpdir $ "extra-file-" ++ show val ++ "-" hClose h return file -- | 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 == return True -- > (doesFileExist =<< withTempFile return) == return False -- > withTempFile readFile' == return "" 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 = do tmpdir <- getTemporaryDirectory dir <- retryBool (\(_ :: IOError) -> True) 5 $ create tmpdir del <- once $ ignore $ removeDirectoryRecursive dir return (dir, del) where create tmpdir = do v <- tempUnique let dir = tmpdir "extra-dir-" ++ show v catchBool isAlreadyExistsError (createDirectoryPrivate dir >> return dir) $ \_ -> create tmpdir -- | Create a temporary directory inside the system temporary directory. -- The directory will be deleted after the action completes. -- -- > withTempDir doesDirectoryExist == return True -- > (doesDirectoryExist =<< withTempDir return) == return False -- > withTempDir listFiles == return [] withTempDir :: (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 -- | Returs 'True' when the contents of both files is the same. sameContent :: Handle -> Handle -> IO Bool sameContent h1 h2 = sameSize h1 h2 &&^ withb (\b1 -> withb $ \b2 -> eq b1 b2) where eq b1 b2 = do r1 <- hGetBuf h1 b1 bufsz r2 <- hGetBuf h2 b2 bufsz if r1 == 0 then return $ r2 == 0 else return (r1 == r2) &&^ bufeq b1 b2 r1 &&^ eq b1 b2 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.4.10/src/System/Info/0000755000000000000000000000000012730320114014045 5ustar0000000000000000extra-1.4.10/src/System/Info/Extra.hs0000644000000000000000000000155112730320114015466 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.4.10/src/System/Environment/0000755000000000000000000000000012730320114015456 5ustar0000000000000000extra-1.4.10/src/System/Environment/Extra.hs0000644000000000000000000000155012730320114017076 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | Extra functions for "System.Environment". All these functions are available in later GHC versions, -- but this code works all the way back to GHC 7.2. module System.Environment.Extra( module System.Environment, getExecutablePath, lookupEnv ) where import System.Environment #if __GLASGOW_HASKELL__ < 706 import Control.Exception.Extra import System.IO.Error -- | Alias for 'getProgName' in GHC 7.4 and below, otherwise -- returns the absolute pathname of the current executable. getExecutablePath :: IO FilePath getExecutablePath = getProgName -- | Return the value of the environment variable var, or Nothing if there is no such value. lookupEnv :: String -> IO (Maybe String) lookupEnv x = catchBool isDoesNotExistError (fmap Just $ getEnv x) (const $ return Nothing) #endif extra-1.4.10/src/System/Directory/0000755000000000000000000000000012730320114015116 5ustar0000000000000000extra-1.4.10/src/System/Directory/Extra.hs0000644000000000000000000000764512730320114016551 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, 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; return $ map (drop (length dir + 1)) res == bs -- > listTest listContents ["bar.txt","foo/baz.txt","zoo"] ["bar.txt","foo","zoo"] listContents :: FilePath -> IO [FilePath] listContents dir = do xs <- getDirectoryContents dir return $ sort [dir x | x <- xs, not $ all (== '.') x] -- | 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. -- -- > listTest listFilesRecursive ["bar.txt","zoo","foo" "baz.txt"] ["bar.txt","zoo","foo" "baz.txt"] listFilesRecursive :: FilePath -> IO [FilePath] listFilesRecursive = listFilesInside (const $ return True) -- | Like 'listFilesRecursive', but with a predicate to decide where to recurse into. -- Typically directories starting with @.@ would be ignored. The initial argument directory -- will have the test applied to it. -- -- > listTest (listFilesInside $ return . not . isPrefixOf "." . takeFileName) -- > ["bar.txt","foo" "baz.txt",".foo" "baz2.txt", "zoo"] ["bar.txt","zoo","foo" "baz.txt"] -- > listTest (listFilesInside $ const $ return False) ["bar.txt"] [] listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (return []) $ do (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir rest <- concatMapM (listFilesInside test) dirs return $ 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.4.10/src/Numeric/0000755000000000000000000000000012730320114013270 5ustar0000000000000000extra-1.4.10/src/Numeric/Extra.hs0000644000000000000000000000242212730320114014707 0ustar0000000000000000 -- | Extra numeric functions - formatting and specialised conversions. module Numeric.Extra( module Numeric, showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat ) where import Numeric import Control.Arrow --------------------------------------------------------------------- -- 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 = a ++ (if n > 0 then "." else "") ++ b ++ replicate (n - length b) '0' where (a,b) = second (drop 1) $ break (== '.') $ 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.4.10/src/Data/0000755000000000000000000000000012730320114012537 5ustar0000000000000000extra-1.4.10/src/Data/Version/0000755000000000000000000000000012730320114014164 5ustar0000000000000000extra-1.4.10/src/Data/Version/Extra.hs0000644000000000000000000000170012730320114015601 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.Version" with extra utilities. -- The package also exports the existing "Data.Version" functions. module Data.Version.Extra( module Data.Version, makeVersion, readVersion ) where import Data.Version import Data.List.Extra import Text.ParserCombinators.ReadP #if __GLASGOW_HASKELL__ < 710 -- | Construct tag-less 'Version' -- -- > showVersion (makeVersion [1,2,3]) == "1.2.3" makeVersion :: [Int] -> Version makeVersion b = Version b [] #endif -- | Read a 'Version' or throw an exception. -- -- > \x -> readVersion (showVersion x) == x -- > readVersion "hello" == undefined readVersion :: String -> Version readVersion 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.4.10/src/Data/Typeable/0000755000000000000000000000000012730320114014304 5ustar0000000000000000extra-1.4.10/src/Data/Typeable/Extra.hs0000644000000000000000000000643012730320114015726 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables, TypeOperators, GADTs, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.Typeable" with extra functions available in later GHC versions. -- The package also exports the existing "Data.Typeable" functions. module Data.Typeable.Extra( typeRep, (:~:)(..), Proxy(..), module Data.Typeable ) where import Data.Typeable #if __GLASGOW_HASKELL__ < 708 import Data.Ix import Data.Monoid import Control.Monad import Control.Applicative -- | Takes a value of type @a@ and returns a concrete representation -- of that type. -- -- > typeRep (Proxy :: Proxy Int) == typeOf (1 :: Int) typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep typeRep _ = typeOf (undefined :: a) infix 4 :~: -- | Propositional equality. If @a :~: b@ is inhabited by some terminating -- value, then the type @a@ is the same as the type @b@. To use this equality -- in practice, pattern-match on the @a :~: b@ to get out the @Refl@ constructor; -- in the body of the pattern-match, the compiler knows that @a ~ b@. data a :~: b where Refl :: a :~: a deriving instance Eq (a :~: b) deriving instance Show (a :~: b) deriving instance Ord (a :~: b) instance a ~ b => Read (a :~: b) where readsPrec d = readParen (d > 10) (\r -> [(Refl, s) | ("Refl",s) <- lex r ]) instance a ~ b => Enum (a :~: b) where toEnum 0 = Refl toEnum _ = errorWithoutStackTrace "Data.Type.Equality.toEnum: bad argument" fromEnum Refl = 0 instance a ~ b => Bounded (a :~: b) where minBound = Refl maxBound = Refl -- | A canonical proxy type data Proxy t = Proxy -- It's common to use (undefined :: Proxy t) and (Proxy :: Proxy t) -- interchangeably, so all of these instances are hand-written to be -- lazy in Proxy arguments. instance Eq (Proxy s) where _ == _ = True instance Ord (Proxy s) where compare _ _ = EQ instance Show (Proxy s) where showsPrec _ _ = showString "Proxy" instance Read (Proxy s) where readsPrec d = readParen (d > 10) (\r -> [(Proxy, s) | ("Proxy",s) <- lex r ]) errorWithoutStackTrace = error instance Enum (Proxy s) where succ _ = errorWithoutStackTrace "Proxy.succ" pred _ = errorWithoutStackTrace "Proxy.pred" fromEnum _ = 0 toEnum 0 = Proxy toEnum _ = errorWithoutStackTrace "Proxy.toEnum: 0 expected" enumFrom _ = [Proxy] enumFromThen _ _ = [Proxy] enumFromThenTo _ _ _ = [Proxy] enumFromTo _ _ = [Proxy] instance Ix (Proxy s) where range _ = [Proxy] index _ _ = 0 inRange _ _ = True rangeSize _ = 1 instance Bounded (Proxy s) where minBound = Proxy maxBound = Proxy instance Monoid (Proxy s) where mempty = Proxy mappend _ _ = Proxy mconcat _ = Proxy instance Functor Proxy where fmap _ _ = Proxy {-# INLINE fmap #-} instance Applicative Proxy where pure _ = Proxy {-# INLINE pure #-} _ <*> _ = Proxy {-# INLINE (<*>) #-} instance Alternative Proxy where empty = Proxy {-# INLINE empty #-} _ <|> _ = Proxy {-# INLINE (<|>) #-} instance Monad Proxy where return = pure _ >>= _ = Proxy {-# INLINE (>>=) #-} instance MonadPlus Proxy where mzero = empty mplus = (<|>) #endif extra-1.4.10/src/Data/Tuple/0000755000000000000000000000000012730320114013630 5ustar0000000000000000extra-1.4.10/src/Data/Tuple/Extra.hs0000644000000000000000000000342012730320114015246 0ustar0000000000000000 -- | 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, -- * Extract from a triple fst3, snd3, thd3 ) 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 -- | 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 extra-1.4.10/src/Data/List/0000755000000000000000000000000012730320114013452 5ustar0000000000000000extra-1.4.10/src/Data/List/Extra.hs0000644000000000000000000005131712730320114015100 0ustar0000000000000000{-# LANGUAGE CPP, TupleSections #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.List" with extra functions of a similar nature. -- The package also exports the existing "Data.List" functions. -- Some of the names and semantics were inspired by the -- package. module Data.List.Extra( module Data.List, -- * String operations lower, upper, trim, trimStart, trimEnd, word1, line1, -- * Splitting dropEnd, takeEnd, splitAtEnd, breakEnd, spanEnd, dropWhileEnd, dropWhileEnd', takeWhileEnd, stripSuffix, stripInfix, stripInfixEnd, wordsBy, linesBy, breakOn, breakOnEnd, splitOn, split, chunksOf, -- * Basics list, uncons, unsnoc, cons, snoc, drop1, mconcatMap, -- * List operations groupSort, groupSortOn, groupSortBy, nubOrd, nubOrdBy, nubOrdOn, nubOn, groupOn, sortOn, disjoint, allSame, anySame, repeatedly, for, firstJust, concatUnzip, concatUnzip3, replace, merge, mergeBy, ) where import Control.Applicative import Data.List import Data.Maybe import Data.Function import Data.Char import Data.Tuple.Extra import Data.Monoid 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 -- | Flipped version of 'map'. -- -- > for [1,2,3] (+1) == [2,3,4] for :: [a] -> (a -> b) -> [b] for = flip map -- | 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 -- | 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 -- | 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 __GLASGOW_HASKELL__ < 709 -- | If the list is empty returns 'Nothing', otherwise returns the 'head' and the 'tail'. -- -- > uncons "test" == Just ('t',"est") -- > uncons "" == Nothing -- > \xs -> uncons xs == if null xs then Nothing else Just (head xs, tail xs) uncons :: [a] -> Maybe (a, [a]) uncons [] = Nothing uncons (x:xs) = Just (x,xs) #endif -- | If 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] -- | 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) -- | 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 perserve 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 (dropWhile isSpace) . break isSpace . dropWhile isSpace -- | 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') #if __GLASGOW_HASKELL__ < 709 -- | Sort a list by comparing the results of a key function applied to each -- element. @sortOn f@ is equivalent to @sortBy (comparing f)@, but has the -- performance advantage of only evaluating @f@ once for each element in the -- input list. This is called the decorate-sort-undecorate paradigm, or -- Schwartzian transform. -- -- > sortOn fst [(3,"z"),(1,""),(3,"a")] == [(1,""),(3,"z"),(3,"a")] sortOn :: Ord b => (a -> b) -> [a] -> [a] sortOn f = map snd . sortBy (compare `on` fst) . map (\x -> let y = f x in y `seq` (y, x)) #endif -- | A version of 'group' where the equality is done on some extracted value. groupOn :: Eq b => (a -> b) -> [a] -> [[a]] groupOn f = groupBy ((==) `on2` f) -- redefine on so we avoid duplicate computation for most values. where (.*.) `on2` f = \x -> let fx = f x in \y -> fx .*. f y -- | A version of 'nub' where the equality is done on some extracted value. -- @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. 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 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 :: 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 -- | 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 patch, 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 :: 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 #if __GLASGOW_HASKELL__ < 704 dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] #endif -- | A version of 'dropWhileEnd' but with different strictness properties. -- The function 'dropWhileEnd' can be used on an infinite list and tests the property -- on each character. In contrast, 'dropWhileEnd'' is strict in the spine of the list -- 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) [] -- | Return the prefix of the second string if its suffix -- matches the entire first string. -- -- Examples: -- -- > stripSuffix "bar" "foobar" == Just "foo" -- > stripSuffix "" "baz" == Just "baz" -- > stripSuffix "foo" "quux" == Nothing stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] stripSuffix a b = fmap 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 :: 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 '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 http://www.cs.kent.ac.uk/people/staff/smk/redblack/Untyped.hs data Color = R | B deriving Show data RB a = E | T Color (RB a) a (RB a) deriving Show {- Insertion and membership test as by Okasaki -} insertRB :: (a -> a -> Ordering) -> a -> RB a -> RB a insertRB cmp x s = T B a z b where T _ a z b = ins s ins E = T R E x E ins s@(T B a y b) = case cmp x y of LT -> balance (ins a) y b GT -> balance a y (ins b) 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 _ a y b) = case cmp x y of LT -> memberRB cmp x a GT -> memberRB cmp x b EQ -> True {- balance: first equation is new, to make it work with a weaker invariant -} balance :: RB a -> a -> RB a -> RB a balance (T R a x b) y (T R c z d) = T R (T B a x b) y (T B c z d) balance (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) balance (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) balance a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) balance a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) balance a x b = T B a x b extra-1.4.10/src/Data/IORef/0000755000000000000000000000000012730320114013503 5ustar0000000000000000extra-1.4.10/src/Data/IORef/Extra.hs0000644000000000000000000000304012730320114015117 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | This module extends "Data.IORef" with operations forcing the value written to the IORef. -- Some of these functions are available in later versions of GHC, but not all. module Data.IORef.Extra( module Data.IORef, modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef' ) 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 #if __GLASGOW_HASKELL__ < 706 -- | Version of 'modifyIORef' that evaluates the function. modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do x <- readIORef ref writeIORef' ref $ f x -- | Strict version of 'atomicModifyIORef'. This forces both the value stored -- in the 'IORef' as well as the value returned. atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b atomicModifyIORef' ref f = do b <- atomicModifyIORef ref (\x -> let (a, b) = f x in (a, a `seq` b)) b `seq` return b -- | Variant of 'writeIORef' with the \"barrier to reordering\" property that -- 'atomicModifyIORef' has. atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref a = do x <- atomicModifyIORef ref (\_ -> (a, ())) x `seq` return () #endif extra-1.4.10/src/Data/Either/0000755000000000000000000000000012730320114013757 5ustar0000000000000000extra-1.4.10/src/Data/Either/Extra.hs0000644000000000000000000000330112730320114015373 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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. module Data.Either.Extra( module Data.Either, isLeft, isRight, fromLeft, fromRight, fromEither ) where import Data.Either -- | 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 :: Either l r -> l fromLeft (Left x) = x -- | 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 :: Either l r -> r fromRight (Right x) = x #if __GLASGOW_HASKELL__ < 708 -- | Test if an 'Either' value is the 'Left' constructor. -- Provided as standard with GHC 7.8 and above. isLeft :: Either l r -> Bool isLeft Left{} = True; isLeft _ = False -- | Test if an 'Either' value is the 'Right' constructor. -- Provided as standard with GHC 7.8 and above. isRight :: Either l r -> Bool isRight Right{} = True; isRight _ = False #endif -- | Pull the value out of an 'Either' where both alternatives -- have the same type. -- -- > \x -> fromEither (Left x ) == x -- > \x -> fromEither (Right x) == x fromEither :: Either a a -> a fromEither = either id id extra-1.4.10/src/Control/0000755000000000000000000000000012730320114013306 5ustar0000000000000000extra-1.4.10/src/Control/Monad/0000755000000000000000000000000012730320114014344 5ustar0000000000000000extra-1.4.10/src/Control/Monad/Extra.hs0000644000000000000000000001537212730320114015773 0ustar0000000000000000{-# LANGUAGE UnboxedTuples #-} -- | 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, unit, maybeM, eitherM, -- * Loops loopM, whileM, -- * Lists partitionM, concatMapM, concatForM, mconcatMapM, mapMaybeM, findM, firstJustM, -- * Booleans whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM ) where import Control.Monad import Control.Applicative import Data.Maybe import Data.Monoid import Prelude -- General utilities -- | Perform some operation on 'Just', given the field inside the 'Just'. -- -- > whenJust Nothing print == return () -- > 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 () whenJustM mg f = maybe (return ()) f =<< mg -- | 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 'either'. eitherM :: Monad m => (a -> m c) -> (b -> m c) -> m (Either a b) -> m c eitherM l r x = either l r =<< x -- 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 [] = return ([], []) partitionM f (x:xs) = do res <- f x (as,bs) <- partitionM f xs return ([x | res]++as, [x | not res]++bs) -- | A version of 'concatMap' that works with a monadic predicate. concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] {-# INLINE concatMapM #-} concatMapM op = foldr f (return []) where f x xs = do x <- op x; if null x then xs else do xs <- xs; return $ x++xs -- | 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 (return []) where f x xs = do x <- op x; case x of Nothing -> xs; Just x -> do xs <- xs; return $ x:xs -- Looping -- | A looping operation, 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 -> return 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 -- Booleans -- | Like 'when', but where the test can be monadic. whenM :: Monad m => m Bool -> m () -> m () whenM b t = ifM b t (return ()) -- | Like 'unless', but where the test can be monadic. unlessM :: Monad m => m Bool -> m () -> m () unlessM b f = ifM b (return ()) 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 (return 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 (return 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 [] = return False anyM p (x:xs) = ifM (p x) (return True) (anyM p xs) -- | 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 [] = return True allM p (x:xs) = ifM (p x) (allM p xs) (return False) -- | 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 [] = return Nothing findM p (x:xs) = ifM (p x) (return $ Just x) (findM p xs) -- | Like 'findM', but also allows you to compute some additional information in the predicate. firstJustM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) firstJustM p [] = return Nothing firstJustM p (x:xs) = maybe (firstJustM p xs) (return . Just) =<< p x extra-1.4.10/src/Control/Exception/0000755000000000000000000000000012730320114015244 5ustar0000000000000000extra-1.4.10/src/Control/Exception/Extra.hs0000644000000000000000000001134212730320114016664 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, CPP #-} {-# 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. module Control.Exception.Extra( module Control.Exception, retry, retryBool, showException, stringException, errorIO, displayException, -- * Exception catching/ignoring ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool ) where import Control.Exception import Control.Monad import Data.List.Extra -- | Fully evaluate an input String. If the String contains embedded exceptions it will produce @\@. -- -- > stringException "test" == return "test" -- > stringException ("test" ++ undefined) == return "test" -- > stringException ("test" ++ undefined ++ "hello") == return "test" -- > stringException ['t','e','s','t',undefined] == return "test" stringException :: String -> IO String stringException x = do r <- try_ $ evaluate $ list [] (\x xs -> x `seq` x:xs) x case r of Left e -> return "" Right [] -> return [] Right (x:xs) -> fmap (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__ < 710 -- | Render this exception value in a human-friendly manner. -- Part of the 'Exception' class in GHC 7.10 onwards. displayException :: Exception e => e -> String displayException = show #endif -- | Ignore any exceptions thrown by the action. -- -- > ignore (print 1) == print 1 -- > ignore (fail "die") == return () ignore :: IO () -> IO () ignore = void . try_ -- | Like error, but in the 'IO' monad. -- Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception. -- -- > try (errorIO "Hello") == return (Left (ErrorCall "Hello")) errorIO :: String -> IO a errorIO = throwIO . ErrorCall -- | 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 -> return 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 $ return \"\") -- @ 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.4.10/src/Control/Concurrent/0000755000000000000000000000000012730320114015430 5ustar0000000000000000extra-1.4.10/src/Control/Concurrent/Extra.hs0000644000000000000000000002145412730320114017055 0ustar0000000000000000{-# LANGUAGE CPP, TupleSections #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | 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, getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, once, onceFork, -- * Lock Lock, newLock, withLock, withLockTry, -- * Var Var, newVar, readVar, modifyVar, modifyVar_, withVar, -- * Barrier Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, ) where import Control.Concurrent import Control.Exception.Extra import Control.Monad.Extra import Data.Maybe -- | 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 #if __GLASGOW_HASKELL__ < 702 -- | A version of 'getNumCapabilities' that works on all versions of GHC, but returns 1 before GHC 7.2. getNumCapabilities :: IO Int getNumCapabilities = return 1 #endif #if __GLASGOW_HASKELL__ < 706 -- | A version of 'setNumCapabilities' that works on all versions of GHC, but has no effect before GHC 7.6. setNumCapabilities :: Int -> IO () setNumCapabilities n = return () #endif #if __GLASGOW_HASKELL__ < 706 -- | fork a thread and call the supplied function when the thread is about -- to terminate, with an exception or a returned value. The function is -- called with asynchronous exceptions masked. -- -- @ -- forkFinally action and_then = -- mask $ \restore -> -- forkIO $ try (restore action) >>= and_then -- @ -- -- This function is useful for informing the parent when a child -- terminates, for example. forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId forkFinally action and_then = mask $ \restore -> forkIO $ try (restore action) >>= and_then #endif -- | Given an action, produce a wrapped action that runs at most once. -- If the function raises an exception, the same exception will be reraised each time. -- -- > let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2 -- > \(x :: IO Int) -> void (once x) == return () -- > \(x :: IO Int) -> join (once x) == x -- > \(x :: IO Int) -> (do y <- once x; y; y) == x -- > \(x :: IO Int) -> (do y <- once x; y ||| y) == x once :: IO a -> IO (IO a) once act = do var <- newVar OncePending let run = either throwIO return return $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of OnceDone x -> return (v, unmask $ run x) OnceRunning x -> return (v, unmask $ run =<< waitBarrier x) OncePending -> do b <- newBarrier return $ (OnceRunning b,) $ do res <- try_ $ unmask act signalBarrier b res modifyVar_ var $ \_ -> return $ 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 return $ either throwIO return =<< waitBarrier bar --------------------------------------------------------------------- -- LOCK -- | Like an MVar, but has no value. -- Used to guarantees single-threaded access, typically to some system resource. -- As an example: -- -- @ -- lock <- 'newLock' -- let output = 'withLock' . 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 = fmap 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 return Nothing) --------------------------------------------------------------------- -- VAR -- | Like an MVar, but must always be full. -- Used to 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 -- | 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 (Var (Either (MVar ()) a)) -- Either a Left empty MVar you should wait or a Right result -- With base 4.7 and above readMVar is atomic so you probably can implement Barrier directly on MVar a -- | Create a new 'Barrier'. newBarrier :: IO (Barrier a) newBarrier = fmap Barrier $ newVar . Left =<< newEmptyMVar -- | Write a value into the Barrier, releasing anyone at 'waitBarrier'. -- Any subsequent attempts to signal the 'Barrier' will throw an exception. signalBarrier :: Barrier a -> a -> IO () signalBarrier (Barrier var) v = mask_ $ do -- use mask so never in an inconsistent state join $ modifyVar var $ \x -> case x of Left bar -> return (Right v, putMVar bar ()) Right res -> error "Control.Concurrent.Extra.signalBarrier, attempt to signal a barrier that has already been signaled" -- | Wait until a barrier has been signaled with 'signalBarrier'. waitBarrier :: Barrier a -> IO a waitBarrier (Barrier var) = do x <- readVar var case x of Right res -> return res Left bar -> do readMVar bar x <- readVar var case x of Right res -> return res Left bar -> error "Cortex.Concurrent.Extra, internal invariant violated in Barrier" -- | 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) = fmap (either (const Nothing) Just) $ readVar bar