extra 0.1 → 0.2
raw patch · 18 files changed
+958/−899 lines, 18 filesdep +unixdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: unix
Dependency ranges changed: base
API changes (from Hackage documentation)
- Data.List.Extra: trim :: String -> String
- Data.List.Extra: trimBy :: (a -> Bool) -> [a] -> [a]
- Data.List.Extra: trimLeft :: String -> String
- Data.List.Extra: trimRight :: String -> String
- Extra: trim :: String -> String
- Extra: trimBy :: (a -> Bool) -> [a] -> [a]
- Extra: trimLeft :: String -> String
- Extra: trimRight :: String -> String
- Extra: withTemporaryFile :: String -> (FilePath -> IO a) -> IO a
- System.IO.Extra: withTemporaryFile :: String -> (FilePath -> IO a) -> IO a
+ Data.List.Extra: cons :: a -> [a] -> [a]
+ Data.List.Extra: drop1 :: [a] -> [a]
+ Data.List.Extra: dropAround :: (a -> Bool) -> [a] -> [a]
+ Data.List.Extra: snoc :: [a] -> a -> [a]
+ Data.List.Extra: strip :: String -> String
+ Data.List.Extra: stripEnd :: String -> String
+ Data.List.Extra: stripStart :: String -> String
+ Extra: (&&^) :: Monad m => m Bool -> m Bool -> m Bool
+ Extra: (||^) :: Monad m => m Bool -> m Bool -> m Bool
+ Extra: cons :: a -> [a] -> [a]
+ Extra: drop1 :: [a] -> [a]
+ Extra: dropAround :: (a -> Bool) -> [a] -> [a]
+ Extra: snoc :: [a] -> a -> [a]
+ Extra: strip :: String -> String
+ Extra: stripEnd :: String -> String
+ Extra: stripStart :: String -> String
+ Extra: withTempDir :: (FilePath -> IO a) -> IO a
+ Extra: withTempFile :: (FilePath -> IO a) -> IO a
+ System.IO.Extra: withTempDir :: (FilePath -> IO a) -> IO a
+ System.IO.Extra: withTempFile :: (FilePath -> IO a) -> IO a
- Data.List.Extra: uncons :: [a] -> (a, [a])
+ Data.List.Extra: uncons :: [a] -> Maybe (a, [a])
- Data.List.Extra: unsnoc :: [a] -> ([a], a)
+ Data.List.Extra: unsnoc :: [a] -> Maybe ([a], a)
- Extra: uncons :: [a] -> (a, [a])
+ Extra: uncons :: [a] -> Maybe (a, [a])
- Extra: unsnoc :: [a] -> ([a], a)
+ Extra: unsnoc :: [a] -> Maybe ([a], a)
Files
- CHANGES.txt +6/−0
- extra.cabal +5/−1
- src/Control/Concurrent/Extra.hs +31/−31
- src/Control/Exception/Extra.hs +71/−71
- src/Control/Monad/Extra.hs +88/−86
- src/Data/Either/Extra.hs +20/−20
- src/Data/IORef/Extra.hs +48/−48
- src/Data/List/Extra.hs +257/−252
- src/Data/Tuple/Extra.hs +27/−27
- src/Extra.hs +42/−42
- src/Numeric/Extra.hs +34/−34
- src/System/Directory/Extra.hs +26/−26
- src/System/Environment/Extra.hs +20/−20
- src/System/IO/Extra.hs +142/−102
- src/System/Info/Extra.hs +47/−47
- src/System/Time/Extra.hs +56/−56
- src/Test.hs +27/−25
- src/TestUtil.hs +11/−11
CHANGES.txt view
@@ -1,4 +1,10 @@ Changelog for Extra +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.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: extra-version: 0.1+version: 0.2 license: BSD3 license-file: LICENSE category: Development@@ -31,6 +31,8 @@ directory, filepath, time+ if !os(windows)+ build-depends: unix exposed-modules: Extra@@ -57,6 +59,8 @@ filepath, time, QuickCheck+ if !os(windows)+ build-depends: unix hs-source-dirs: src ghc-options: -main-is Test.main main-is: Test.hs
src/Control/Concurrent/Extra.hs view
@@ -1,31 +1,31 @@-{-# LANGUAGE CPP #-} - -module Control.Concurrent.Extra( - module Control.Concurrent, - withNumCapabilities, setNumCapabilities - ) where - -import Control.Concurrent -#if __GLASGOW_HASKELL__ >= 706 - hiding (setNumCapabilities) -import qualified Control.Concurrent -#endif -import Control.Exception - - --- | 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 - - --- | A version of 'setNumCapabilities' that works on all versions of GHC, but has no effect before GHC 7.6. -setNumCapabilities :: Int -> IO () -#if __GLASGOW_HASKELL__ >= 706 -setNumCapabilities n = Control.Concurrent.setNumCapabilities n -#else -setNumCapabilities n = return () -#endif +{-# LANGUAGE CPP #-}++module Control.Concurrent.Extra(+ module Control.Concurrent,+ withNumCapabilities, setNumCapabilities+ ) where++import Control.Concurrent+#if __GLASGOW_HASKELL__ >= 706+ hiding (setNumCapabilities)+import qualified Control.Concurrent+#endif+import Control.Exception+++-- | 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+++-- | A version of 'setNumCapabilities' that works on all versions of GHC, but has no effect before GHC 7.6.+setNumCapabilities :: Int -> IO ()+#if __GLASGOW_HASKELL__ >= 706+setNumCapabilities n = Control.Concurrent.setNumCapabilities n+#else+setNumCapabilities n = return ()+#endif
src/Control/Exception/Extra.hs view
@@ -1,71 +1,71 @@- -module Control.Exception.Extra( - module Control.Exception, - retry, showException, ignore, - catch_, handle_, try_, - catchJust_, handleJust_, tryJust_, - catchBool, handleBool, tryBool - ) where - -import Control.Exception -import Control.Monad - - --- | Print an exception, but if that exception itself contains exceptions, simply print --- @\<NestedException\>@. Since Haskell is a lazy language it is possible to throw --- exceptions that are themselves undefined. This function is useful to report them to users. -showException :: SomeException -> IO String -showException = f . show - where - f xs = do - r <- try_ $ evaluate xs - case r of - Left e -> return "<NestedException>" - Right [] -> return [] - Right (x:xs) -> fmap (x :) $ f xs - - --- | Ignore any exceptions thrown by the action and continue as normal. -ignore :: IO () -> IO () -ignore = void . try_ - - -retry :: Int -> IO a -> IO a -retry i x | i <= 0 = error "retry count must be 1 or more" -retry 1 x = x -retry i x = do - res <- try_ x - case res of - Left _ -> retry (i-1) x - Right v -> return v - - -catch_ :: IO a -> (SomeException -> IO a) -> IO a -catch_ = Control.Exception.catch - -catchJust_ :: (SomeException -> Maybe b) -> IO a -> (b -> IO a) -> IO a -catchJust_ = catchJust - -handle_ :: (SomeException -> IO a) -> IO a -> IO a -handle_ = handle - -handleJust_ :: (SomeException -> Maybe b) -> (b -> IO a) -> IO a -> IO a -handleJust_ = handleJust - -try_ :: IO a -> IO (Either SomeException a) -try_ = try - -tryJust_ :: (SomeException -> Maybe b) -> IO a -> IO (Either b a) -tryJust_ = tryJust - -catchBool :: Exception e => (e -> Bool) -> IO a -> (e -> IO a) -> IO a -catchBool f a b = catchJust (bool f) a b - -handleBool :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a -handleBool f a b = handleJust (bool f) a b - -tryBool :: Exception e => (e -> Bool) -> IO a -> IO (Either e a) -tryBool f a = tryJust (bool f) a - -bool :: Exception e => (e -> Bool) -> (e -> Maybe e) -bool f x = if f x then Just x else Nothing ++module Control.Exception.Extra(+ module Control.Exception,+ retry, showException, ignore,+ catch_, handle_, try_,+ catchJust_, handleJust_, tryJust_,+ catchBool, handleBool, tryBool+ ) where++import Control.Exception+import Control.Monad+++-- | Print an exception, but if that exception itself contains exceptions, simply print+-- @\<NestedException\>@. Since Haskell is a lazy language it is possible to throw+-- exceptions that are themselves undefined. This function is useful to report them to users.+showException :: SomeException -> IO String+showException = f . show+ where+ f xs = do+ r <- try_ $ evaluate xs+ case r of+ Left e -> return "<NestedException>"+ Right [] -> return []+ Right (x:xs) -> fmap (x :) $ f xs+++-- | Ignore any exceptions thrown by the action and continue as normal.+ignore :: IO () -> IO ()+ignore = void . try_+++retry :: Int -> IO a -> IO a+retry i x | i <= 0 = error "retry count must be 1 or more"+retry 1 x = x+retry i x = do+ res <- try_ x+ case res of+ Left _ -> retry (i-1) x+ Right v -> return v+++catch_ :: IO a -> (SomeException -> IO a) -> IO a+catch_ = Control.Exception.catch++catchJust_ :: (SomeException -> Maybe b) -> IO a -> (b -> IO a) -> IO a+catchJust_ = catchJust++handle_ :: (SomeException -> IO a) -> IO a -> IO a+handle_ = handle++handleJust_ :: (SomeException -> Maybe b) -> (b -> IO a) -> IO a -> IO a+handleJust_ = handleJust++try_ :: IO a -> IO (Either SomeException a)+try_ = try++tryJust_ :: (SomeException -> Maybe b) -> IO a -> IO (Either b a)+tryJust_ = tryJust++catchBool :: Exception e => (e -> Bool) -> IO a -> (e -> IO a) -> IO a+catchBool f a b = catchJust (bool f) a b++handleBool :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a+handleBool f a b = handleJust (bool f) a b++tryBool :: Exception e => (e -> Bool) -> IO a -> IO (Either e a)+tryBool f a = tryJust (bool f) a++bool :: Exception e => (e -> Bool) -> (e -> Maybe e)+bool f x = if f x then Just x else Nothing
src/Control/Monad/Extra.hs view
@@ -1,86 +1,88 @@- --- If you need a wider selection of monad loops and list generalisations, --- see <http://hackage.haskell.org/package/monad-loops> -module Control.Monad.Extra( - module Control.Monad, - whenJust, - unit, - partitionM, concatMapM, - loopM, whileM, - ifM, notM, (||^), (&&^), orM, andM, anyM, allM, - findM, firstJustM - ) where - -import Control.Monad -import Control.Applicative - --- General utilities - -whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () -whenJust mg f = maybe (pure ()) f mg - -unit :: m () -> m () -unit = id - --- Data.List for Monad - -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) - - -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f = liftM concat . mapM f - --- Looping - -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 - -whileM :: Monad m => m Bool -> m () -whileM act = do - b <- act - when b $ whileM act - --- Booleans - -ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM b t f = do b <- b; if b then t else f - -notM :: Functor m => m Bool -> m Bool -notM = fmap not - -(||^), (&&^) :: Monad m => m Bool -> m Bool -> m Bool -(||^) a b = ifM a (return True) b -(&&^) a b = ifM a b (return False) - -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) - -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) - -orM :: Monad m => [m Bool] -> m Bool -orM = anyM id - -andM :: Monad m => [m Bool] -> m Bool -andM = allM id - --- Searching - -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) - -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 ++-- If you need a wider selection of monad loops and list generalisations,+-- see <http://hackage.haskell.org/package/monad-loops>+module Control.Monad.Extra(+ module Control.Monad,+ whenJust,+ unit,+ partitionM, concatMapM,+ loopM, whileM,+ ifM, notM, (||^), (&&^), orM, andM, anyM, allM,+ findM, firstJustM+ ) where++import Control.Monad+import Control.Applicative++-- General utilities++whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust mg f = maybe (pure ()) f mg++unit :: m () -> m ()+unit = id++-- Data.List for Monad++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)+++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = liftM concat . mapM f++-- Looping++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++whileM :: Monad m => m Bool -> m ()+whileM act = do+ b <- act+ when b $ whileM act++-- Booleans++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do b <- b; if b then t else f++notM :: Functor m => m Bool -> m Bool+notM = fmap not++-- > Just False &&^ undefined == Just False+-- > Just True &&^ Just True == Just True+(||^), (&&^) :: Monad m => m Bool -> m Bool -> m Bool+(||^) a b = ifM a (return True) b+(&&^) a b = ifM a b (return False)++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)++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)++orM :: Monad m => [m Bool] -> m Bool+orM = anyM id++andM :: Monad m => [m Bool] -> m Bool+andM = allM id++-- Searching++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)++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
src/Data/Either/Extra.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} - -module Data.Either.Extra( - module Data.Either, - isLeft, isRight, fromLeft, fromRight, fromEither - ) where - -import Data.Either - -fromLeft (Left x) = x -fromRight (Right x) = x - -#if __GLASGOW_HASKELL__ < 708 -isLeft Left{} = True; isLeft _ = False -isRight Right{} = True; isRight _ = False -#endif - -fromEither :: Either a a -> a -fromEither = either id id +{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}++module Data.Either.Extra(+ module Data.Either,+ isLeft, isRight, fromLeft, fromRight, fromEither+ ) where++import Data.Either++fromLeft (Left x) = x+fromRight (Right x) = x++#if __GLASGOW_HASKELL__ < 708+isLeft Left{} = True; isLeft _ = False+isRight Right{} = True; isRight _ = False+#endif++fromEither :: Either a a -> a+fromEither = either id id
src/Data/IORef/Extra.hs view
@@ -1,48 +1,48 @@-{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} - -module Data.IORef.Extra( - module Data.IORef, - modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef' - ) where - -import Data.IORef -import Control.Exception - - --- Evaluates before writing to the IORef -writeIORef' :: IORef a -> a -> IO () -writeIORef' ref x = do - evaluate x - writeIORef ref x - -atomicWriteIORef' :: IORef a -> a -> IO () -atomicWriteIORef' ref x = do - evaluate x - atomicWriteIORef ref x - - -#if __GLASGOW_HASKELL__ < 706 - ---------------------------------------------------------------------- --- Data.IORef - --- Two 's because GHC 7.6 has a strict modifyIORef -modifyIORef' :: IORef a -> (a -> a) -> IO () -modifyIORef' ref f = do - x <- readIORef ref - writeIORef' ref $ f x - -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 - -atomicWriteIORef :: IORef a -> a -> IO () -atomicWriteIORef ref a = do - x <- atomicModifyIORef ref (\_ -> (a, ())) - x `seq` return () - -#endif +{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}++module Data.IORef.Extra(+ module Data.IORef,+ modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef'+ ) where++import Data.IORef+import Control.Exception+++-- Evaluates before writing to the IORef+writeIORef' :: IORef a -> a -> IO ()+writeIORef' ref x = do+ evaluate x+ writeIORef ref x++atomicWriteIORef' :: IORef a -> a -> IO ()+atomicWriteIORef' ref x = do+ evaluate x+ atomicWriteIORef ref x+++#if __GLASGOW_HASKELL__ < 706++---------------------------------------------------------------------+-- Data.IORef++-- Two 's because GHC 7.6 has a strict modifyIORef+modifyIORef' :: IORef a -> (a -> a) -> IO ()+modifyIORef' ref f = do+ x <- readIORef ref+ writeIORef' ref $ f x++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++atomicWriteIORef :: IORef a -> a -> IO ()+atomicWriteIORef ref a = do+ x <- atomicModifyIORef ref (\_ -> (a, ()))+ x `seq` return ()++#endif
src/Data/List/Extra.hs view
@@ -1,252 +1,257 @@-{-# 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 @text@ package. -module Data.List.Extra( - module Data.List, - lower, upper, trim, trimLeft, trimRight, trimBy, word1, - list, uncons, unsnoc, - groupSort, groupSortOn, nubOn, groupOn, sortOn, - chop, for, - rep, reps, - disjoint, distinct, - dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, takeWhileEnd, stripSuffix, - concatUnzip, - merge, mergeBy, replace, wordsBy, linesBy, firstJust, - breakOn, breakOnEnd, splitOn, split, chunksOf - ) where - -import Data.List -import Data.Function -import Data.Ord -import Control.Arrow -import Data.Char -import Data.Tuple.Extra - - -chop :: ([a] -> (b, [a])) -> [a] -> [b] -chop f [] = [] -chop f as = b : chop f as' - where (b, as') = f as - -rep :: Eq a => a -> a -> a -> a -rep from to x = if x == from then to else x - -reps :: Eq a => a -> a -> [a] -> [a] -reps from to = map (rep from to) - - -for :: [a] -> (a -> b) -> [b] -for = flip map - -disjoint :: Eq a => [a] -> [a] -> Bool -disjoint xs = null . intersect xs - -distinct :: Eq a => [a] -> Bool -distinct xs = length xs == length (nub xs) - - -list :: b -> (a -> [a] -> b) -> [a] -> b -list nil cons [] = nil -list nil cons (x:xs) = cons x xs - -uncons :: [a] -> (a,[a]) -uncons [] = error "Uncons on an empty list" -uncons (x:xs) = (x,xs) - -unsnoc :: [a] -> ([a],a) -unsnoc [] = error "Unsnoc on empty list" -unsnoc [x] = ([], x) -unsnoc (x:xs) = (x:a, b) - where (a,b) = unsnoc xs - - -takeEnd :: Int -> [a] -> [a] -takeEnd i = reverse . take i . reverse - -dropEnd :: Int -> [a] -> [a] -dropEnd i = reverse . drop i . reverse - -concatUnzip :: [([a], [b])] -> ([a], [b]) -concatUnzip = (concat *** concat) . unzip - - -takeWhileEnd :: (a -> Bool) -> [a] -> [a] -takeWhileEnd f = reverse . takeWhile f . reverse - - -trim, trimLeft, trimRight :: String -> String -trimLeft = dropWhile isSpace -trimRight = dropWhileEnd isSpace -trim = trimRight . trimLeft - -lower :: String -> String -lower = map toLower - -upper :: String -> String -upper = map toUpper - -trimBy :: (a -> Bool) -> [a] -> [a] -trimBy f = dropWhileEnd f . dropWhile f - - -word1 :: String -> (String, String) -word1 x = second (dropWhile isSpace) $ break isSpace $ dropWhile isSpace x - - -sortOn :: Ord b => (a -> b) -> [a] -> [a] -sortOn f = sortBy (comparing f) - -groupOn :: Eq b => (a -> b) -> [a] -> [[a]] -groupOn f = groupBy ((==) `on` f) - -nubOn :: Eq b => (a -> b) -> [a] -> [a] -nubOn f = nubBy ((==) `on` f) - -groupSort :: Ord k => [(k, v)] -> [(k, [v])] -groupSort = groupSortOn id - -groupSortOn :: Ord a => (k -> a) -> [(k, v)] -> [(k, [v])] -groupSortOn f = map (\x -> (fst $ head x, map snd x)) . groupOn (f . fst) . sortOn (f . fst) - - -merge :: Ord a => [a] -> [a] -> [a] -merge = mergeBy compare - - -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 :: String -> String -> String -> String -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 [] = [] - - -breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) -breakEnd f xs = case break f $ reverse xs of - (_, []) -> (xs, []) - (as, b:bs) -> (reverse bs, b:reverse as) - -spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) -spanEnd f xs = breakEnd (not . f) xs - - -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 - -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 - -firstJust :: (a -> Maybe b) -> [a] -> Maybe b -firstJust p [] = Nothing -firstJust p (x:xs) = maybe (firstJust p xs) Just (p x) - -drop1 :: [a] -> [a] -drop1 [] = [] -drop1 (x:xs) = xs - - --- | 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. --- --- Examples: --- --- > breakOn "::" "a::b::c" == ("a", "::b::c") --- > breakOn "/" "foobar" == ("foobar", "") --- --- Laws: --- --- > \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 = (reverse *** 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. --- --- Examples: --- --- > 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" "" == [""] --- --- and --- --- > \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. eg. --- --- > split (=='a') "aabbaca" == ["","","bb","c",""] --- > split (=='a') "" == [""] -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 - --- | 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) - - -chunksOf :: Int -> [a] -> [[a]] -chunksOf i _ | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i -chunksOf i [] = [] -chunksOf i xs = a : chunksOf i b - where (a,b) = splitAt i xs - +{-# 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 @text@ package.+module Data.List.Extra(+ module Data.List,+ lower, upper, strip, stripStart, stripEnd, dropAround, word1, drop1,+ list, uncons, unsnoc, cons, snoc,+ groupSort, groupSortOn, nubOn, groupOn, sortOn,+ chop, for,+ rep, reps,+ disjoint, distinct,+ dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, takeWhileEnd, stripSuffix,+ concatUnzip,+ merge, mergeBy, replace, wordsBy, linesBy, firstJust,+ breakOn, breakOnEnd, splitOn, split, chunksOf+ ) where++import Data.List+import Data.Function+import Data.Ord+import Control.Arrow+import Data.Char+import Data.Tuple.Extra+++chop :: ([a] -> (b, [a])) -> [a] -> [b]+chop f [] = []+chop f as = b : chop f as'+ where (b, as') = f as++rep :: Eq a => a -> a -> a -> a+rep from to x = if x == from then to else x++reps :: Eq a => a -> a -> [a] -> [a]+reps from to = map (rep from to)+++for :: [a] -> (a -> b) -> [b]+for = flip map++disjoint :: Eq a => [a] -> [a] -> Bool+disjoint xs = null . intersect xs++distinct :: Eq a => [a] -> Bool+distinct xs = length xs == length (nub xs)+++list :: b -> (a -> [a] -> b) -> [a] -> b+list nil cons [] = nil+list nil cons (x:xs) = cons x xs++uncons :: [a] -> Maybe (a, [a])+uncons [] = Nothing+uncons (x:xs) = Just (x,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++cons :: a -> [a] -> [a]+cons = (:)++snoc :: [a] -> a -> [a]+snoc xs x = xs ++ [x]++takeEnd :: Int -> [a] -> [a]+takeEnd i = reverse . take i . reverse++dropEnd :: Int -> [a] -> [a]+dropEnd i = reverse . drop i . reverse++concatUnzip :: [([a], [b])] -> ([a], [b])+concatUnzip = (concat *** concat) . unzip+++takeWhileEnd :: (a -> Bool) -> [a] -> [a]+takeWhileEnd f = reverse . takeWhile f . reverse+++strip, stripStart, stripEnd :: String -> String+stripStart = dropWhile isSpace+stripEnd = dropWhileEnd isSpace+strip = dropAround isSpace++lower :: String -> String+lower = map toLower++upper :: String -> String+upper = map toUpper++dropAround :: (a -> Bool) -> [a] -> [a]+dropAround f = dropWhileEnd f . dropWhile f+++word1 :: String -> (String, String)+word1 x = second (dropWhile isSpace) $ break isSpace $ dropWhile isSpace x+++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f = sortBy (comparing f)++groupOn :: Eq b => (a -> b) -> [a] -> [[a]]+groupOn f = groupBy ((==) `on` f)++nubOn :: Eq b => (a -> b) -> [a] -> [a]+nubOn f = nubBy ((==) `on` f)++groupSort :: Ord k => [(k, v)] -> [(k, [v])]+groupSort = groupSortOn id++groupSortOn :: Ord a => (k -> a) -> [(k, v)] -> [(k, [v])]+groupSortOn f = map (\x -> (fst $ head x, map snd x)) . groupOn (f . fst) . sortOn (f . fst)+++merge :: Ord a => [a] -> [a] -> [a]+merge = mergeBy compare+++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 :: String -> String -> String -> String+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 [] = []+++breakEnd :: (a -> Bool) -> [a] -> ([a], [a])+breakEnd f xs = case break f $ reverse xs of+ (_, []) -> (xs, [])+ (as, b:bs) -> (reverse bs, b:reverse as)++spanEnd :: (a -> Bool) -> [a] -> ([a], [a])+spanEnd f xs = breakEnd (not . f) xs+++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++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++firstJust :: (a -> Maybe b) -> [a] -> Maybe b+firstJust p [] = Nothing+firstJust p (x:xs) = maybe (firstJust p xs) Just (p x)++drop1 :: [a] -> [a]+drop1 [] = []+drop1 (x:xs) = xs+++-- | 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.+--+-- Examples:+--+-- > breakOn "::" "a::b::c" == ("a", "::b::c")+-- > breakOn "/" "foobar" == ("foobar", "")+--+-- Laws:+--+-- > \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 = (reverse *** 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.+--+-- Examples:+--+-- > 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" "" == [""]+--+-- and+--+-- > \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. eg.+--+-- > split (=='a') "aabbaca" == ["","","bb","c",""]+-- > split (=='a') "" == [""]+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++-- | 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)+++chunksOf :: Int -> [a] -> [[a]]+chunksOf i _ | i <= 0 = error $ "chunksOf, number must be positive, got " ++ show i+chunksOf i [] = []+chunksOf i xs = a : chunksOf i b+ where (a,b) = splitAt i xs+
src/Data/Tuple/Extra.hs view
@@ -1,27 +1,27 @@- -module Data.Tuple.Extra( - module Data.Tuple, - dupe, fst3, snd3, thd3, concat2, concat3 - ) where - -import Data.Tuple - -fst3 :: (a,b,c) -> a -fst3 (a,b,c) = a - -snd3 :: (a,b,c) -> b -snd3 (a,b,c) = b - -thd3 :: (a,b,c) -> c -thd3 (a,b,c) = c - -concat3 :: [([a],[b],[c])] -> ([a],[b],[c]) -concat3 xs = (concat a, concat b, concat c) - where (a,b,c) = unzip3 xs - -concat2 :: [([a],[b])] -> ([a],[b]) -concat2 xs = (concat a, concat b) - where (a,b) = unzip xs - -dupe :: a -> (a,a) -dupe x = (x,x) ++module Data.Tuple.Extra(+ module Data.Tuple,+ dupe, fst3, snd3, thd3, concat2, concat3+ ) where++import Data.Tuple++fst3 :: (a,b,c) -> a+fst3 (a,b,c) = a++snd3 :: (a,b,c) -> b+snd3 (a,b,c) = b++thd3 :: (a,b,c) -> c+thd3 (a,b,c) = c++concat3 :: [([a],[b],[c])] -> ([a],[b],[c])+concat3 xs = (concat a, concat b, concat c)+ where (a,b,c) = unzip3 xs++concat2 :: [([a],[b])] -> ([a],[b])+concat2 xs = (concat a, concat b)+ where (a,b) = unzip xs++dupe :: a -> (a,a)+dupe x = (x,x)
src/Extra.hs view
@@ -1,42 +1,42 @@-module Extra( - -- * Control.Concurrent.Extra - withNumCapabilities, setNumCapabilities, - -- * Control.Exception.Extra - retry, showException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, - -- * Control.Monad.Extra - whenJust, unit, partitionM, concatMapM, loopM, whileM, ifM, notM, orM, andM, anyM, allM, findM, firstJustM, - -- * Data.Either.Extra - isLeft, isRight, fromLeft, fromRight, fromEither, - -- * Data.IORef.Extra - modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef', - -- * Data.List.Extra - lower, upper, trim, trimLeft, trimRight, trimBy, word1, list, uncons, unsnoc, groupSort, groupSortOn, nubOn, groupOn, sortOn, chop, for, rep, reps, disjoint, distinct, dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, takeWhileEnd, stripSuffix, concatUnzip, merge, mergeBy, replace, wordsBy, linesBy, firstJust, breakOn, breakOnEnd, splitOn, split, chunksOf, - -- * Data.Tuple.Extra - dupe, fst3, snd3, thd3, concat2, concat3, - -- * Numeric.Extra - showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat, - -- * System.Directory.Extra - withCurrentDirectory, getDirectoryContentsRecursive, - -- * System.Environment.Extra - getExecutablePath, lookupEnv, - -- * System.Info.Extra - isWindows, getProcessorCount, - -- * System.IO.Extra - readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTemporaryFile, captureOutput, withBuffering, - -- * System.Time.Extra - sleep, subtractTime, showTime, 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 Numeric.Extra -import System.Directory.Extra -import System.Environment.Extra -import System.Info.Extra -import System.IO.Extra -import System.Time.Extra +module Extra(+ -- * Control.Concurrent.Extra+ withNumCapabilities, setNumCapabilities,+ -- * Control.Exception.Extra+ retry, showException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool,+ -- * Control.Monad.Extra+ whenJust, unit, partitionM, concatMapM, loopM, whileM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, findM, firstJustM,+ -- * Data.Either.Extra+ isLeft, isRight, fromLeft, fromRight, fromEither,+ -- * Data.IORef.Extra+ modifyIORef', writeIORef', atomicModifyIORef', atomicWriteIORef, atomicWriteIORef',+ -- * Data.List.Extra+ lower, upper, strip, stripStart, stripEnd, dropAround, word1, drop1, list, uncons, unsnoc, cons, snoc, groupSort, groupSortOn, nubOn, groupOn, sortOn, chop, for, rep, reps, disjoint, distinct, dropEnd, takeEnd, breakEnd, spanEnd, dropWhileEnd, takeWhileEnd, stripSuffix, concatUnzip, merge, mergeBy, replace, wordsBy, linesBy, firstJust, breakOn, breakOnEnd, splitOn, split, chunksOf,+ -- * Data.Tuple.Extra+ dupe, fst3, snd3, thd3, concat2, concat3,+ -- * Numeric.Extra+ showDP, intToDouble, intToFloat, floatToDouble, doubleToFloat,+ -- * System.Directory.Extra+ withCurrentDirectory, getDirectoryContentsRecursive,+ -- * System.Environment.Extra+ getExecutablePath, lookupEnv,+ -- * System.Info.Extra+ isWindows, getProcessorCount,+ -- * System.IO.Extra+ readFileEncoding, readFileUTF8, readFileBinary, readFile', readFileEncoding', readFileUTF8', readFileBinary', writeFileEncoding, writeFileUTF8, writeFileBinary, withTempFile, withTempDir, captureOutput, withBuffering,+ -- * System.Time.Extra+ sleep, subtractTime, showTime, 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 Numeric.Extra+import System.Directory.Extra+import System.Environment.Extra+import System.Info.Extra+import System.IO.Extra+import System.Time.Extra
src/Numeric/Extra.hs view
@@ -1,34 +1,34 @@- -module Numeric.Extra( - module Numeric, - showDP, - intToDouble, intToFloat, floatToDouble, doubleToFloat - ) where - -import Numeric -import Control.Arrow - ---------------------------------------------------------------------- --- Data.String - -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 - -intToDouble :: Int -> Double -intToDouble = fromInteger . toInteger - -intToFloat :: Int -> Float -intToFloat = fromInteger . toInteger - -floatToDouble :: Float -> Double -floatToDouble = fromRational . toRational - -doubleToFloat :: Double -> Float -doubleToFloat = fromRational . toRational - - ++module Numeric.Extra(+ module Numeric,+ showDP,+ intToDouble, intToFloat, floatToDouble, doubleToFloat+ ) where++import Numeric+import Control.Arrow++---------------------------------------------------------------------+-- Data.String++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++intToDouble :: Int -> Double+intToDouble = fromInteger . toInteger++intToFloat :: Int -> Float+intToFloat = fromInteger . toInteger++floatToDouble :: Float -> Double+floatToDouble = fromRational . toRational++doubleToFloat :: Double -> Float+doubleToFloat = fromRational . toRational++
src/System/Directory/Extra.hs view
@@ -1,26 +1,26 @@- -module System.Directory.Extra( - module System.Directory, - withCurrentDirectory, getDirectoryContentsRecursive - ) where - -import System.Directory -import Control.Monad.Extra -import System.FilePath -import Data.List -import Control.Exception - - -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory dir act = - bracket getCurrentDirectory setCurrentDirectory $ const $ do - setCurrentDirectory dir; act - -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive dir = do - xs <- getDirectoryContents dir - (dirs,files) <- partitionM doesDirectoryExist [dir </> x | x <- xs, not $ isBadDir x] - rest <- concatMapM getDirectoryContentsRecursive $ sort dirs - return $ sort files ++ rest - where - isBadDir x = "." `isPrefixOf` x -- FIXME, need a version that can also exclude _ dirs ++module System.Directory.Extra(+ module System.Directory,+ withCurrentDirectory, getDirectoryContentsRecursive+ ) where++import System.Directory+import Control.Monad.Extra+import System.FilePath+import Data.List+import Control.Exception+++withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory dir act =+ bracket getCurrentDirectory setCurrentDirectory $ const $ do+ setCurrentDirectory dir; act++getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive dir = do+ xs <- getDirectoryContents dir+ (dirs,files) <- partitionM doesDirectoryExist [dir </> x | x <- xs, not $ isBadDir x]+ rest <- concatMapM getDirectoryContentsRecursive $ sort dirs+ return $ sort files ++ rest+ where+ isBadDir x = "." `isPrefixOf` x -- FIXME, need a version that can also exclude _ dirs
src/System/Environment/Extra.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} - -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 - -getExecutablePath :: IO FilePath -getExecutablePath = getProgName - -lookupEnv :: String -> IO (Maybe String) -lookupEnv x = catchBool isDoesNotExistError (fmap Just $ getEnv x) (const $ return Nothing) -#endif +{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}++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++getExecutablePath :: IO FilePath+getExecutablePath = getProgName++lookupEnv :: String -> IO (Maybe String)+lookupEnv x = catchBool isDoesNotExistError (fmap Just $ getEnv x) (const $ return Nothing)+#endif
src/System/IO/Extra.hs view
@@ -1,102 +1,142 @@-{-# LANGUAGE ScopedTypeVariables #-} - -module System.IO.Extra( - module System.IO, - readFileEncoding, readFileUTF8, readFileBinary, - readFile', readFileEncoding', readFileUTF8', readFileBinary', - writeFileEncoding, writeFileUTF8, writeFileBinary, - withTemporaryFile, - captureOutput, - withBuffering, - ) where - -import System.IO -import System.Directory -import Control.Exception as E -import GHC.IO.Handle(hDuplicate,hDuplicateTo) - - --- File reading - -readFileEncoding :: TextEncoding -> FilePath -> IO String -readFileEncoding enc file = do - h <- openFile file ReadMode - hSetEncoding h enc - hGetContents h - -readFileUTF8 :: FilePath -> IO String -readFileUTF8 = readFileEncoding utf8 - -readFileBinary :: FilePath -> IO String -readFileBinary file = do - h <- openBinaryFile file ReadMode - hGetContents h - --- Strict file reading - -readFile' :: FilePath -> IO String -readFile' file = withFile file ReadMode $ \h -> do - s <- hGetContents h - evaluate $ length s - return s - -readFileEncoding' :: TextEncoding -> FilePath -> IO String -readFileEncoding' e file = withFile file ReadMode $ \h -> do - hSetEncoding h e - s <- hGetContents h - evaluate $ length s - return s - -readFileUTF8' :: FilePath -> IO String -readFileUTF8' = readFileEncoding' utf8 - -readFileBinary' :: FilePath -> IO String -readFileBinary' file = withBinaryFile file ReadMode $ \h -> do - s <- hGetContents h - evaluate $ length s - return s - --- File writing - -writeFileEncoding :: TextEncoding -> FilePath -> String -> IO () -writeFileEncoding enc file x = withFile x WriteMode $ \h -> do - hSetEncoding h enc - hPutStr h x - -writeFileUTF8 :: FilePath -> String -> IO () -writeFileUTF8 = writeFileEncoding utf8 - -writeFileBinary :: FilePath -> String -> IO () -writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x - --- Other - -withTemporaryFile :: String -> (FilePath -> IO a) -> IO a -withTemporaryFile pat act = do - tmp <- getTemporaryDirectory - bracket (openTempFile tmp pat) (removeFile . fst) $ - \(file,h) -> hClose h >> act file - - -captureOutput :: IO () -> IO String -captureOutput act = withTemporaryFile "extra-capture.txt" $ \file -> do - h <- openFile file ReadWriteMode - bout <- hGetBuffering stdout - berr <- hGetBuffering stderr - sto <- hDuplicate stdout - ste <- hDuplicate stderr - hDuplicateTo h stdout - hDuplicateTo h stderr - hClose h - act - hDuplicateTo sto stdout - hDuplicateTo ste stderr - hSetBuffering stdout bout - hSetBuffering stderr berr - readFile' file - - -withBuffering :: Handle -> BufferMode -> IO a -> IO a -withBuffering h m act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do - hSetBuffering h m - act +{-# LANGUAGE ScopedTypeVariables, CPP #-}++-- | More advanced temporary file manipulation functions can be found in the @exceptions@ package.+module System.IO.Extra(+ module System.IO,+ readFileEncoding, readFileUTF8, readFileBinary,+ readFile', readFileEncoding', readFileUTF8', readFileBinary',+ writeFileEncoding, writeFileUTF8, writeFileBinary,+ withTempFile, withTempDir,+ captureOutput,+ withBuffering,+ ) where++import System.IO+import Control.Exception.Extra as E+import GHC.IO.Handle(hDuplicate,hDuplicateTo)+import System.Directory+import System.IO.Error+import System.FilePath+import Data.Char+import Data.Time.Clock++#ifndef mingw32_HOST_OS+import qualified System.Posix+#endif+++-- File reading++readFileEncoding :: TextEncoding -> FilePath -> IO String+readFileEncoding enc file = do+ h <- openFile file ReadMode+ hSetEncoding h enc+ hGetContents h++readFileUTF8 :: FilePath -> IO String+readFileUTF8 = readFileEncoding utf8++readFileBinary :: FilePath -> IO String+readFileBinary file = do+ h <- openBinaryFile file ReadMode+ hGetContents h++-- Strict file reading++readFile' :: FilePath -> IO String+readFile' file = withFile file ReadMode $ \h -> do+ s <- hGetContents h+ evaluate $ length s+ return s++readFileEncoding' :: TextEncoding -> FilePath -> IO String+readFileEncoding' e file = withFile file ReadMode $ \h -> do+ hSetEncoding h e+ s <- hGetContents h+ evaluate $ length s+ return s++readFileUTF8' :: FilePath -> IO String+readFileUTF8' = readFileEncoding' utf8++readFileBinary' :: FilePath -> IO String+readFileBinary' file = withBinaryFile file ReadMode $ \h -> do+ s <- hGetContents h+ evaluate $ length s+ return s++-- File writing++writeFileEncoding :: TextEncoding -> FilePath -> String -> IO ()+writeFileEncoding enc file x = withFile x WriteMode $ \h -> do+ hSetEncoding h enc+ hPutStr h x++writeFileUTF8 :: FilePath -> String -> IO ()+writeFileUTF8 = writeFileEncoding utf8++writeFileBinary :: FilePath -> String -> IO ()+writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x++-- Other++captureOutput :: IO () -> IO String+captureOutput act = withTempFile $ \file -> do+ h <- openFile file ReadWriteMode+ bout <- hGetBuffering stdout+ berr <- hGetBuffering stderr+ sto <- hDuplicate stdout+ ste <- hDuplicate stderr+ hDuplicateTo h stdout+ hDuplicateTo h stderr+ hClose h+ act+ hDuplicateTo sto stdout+ hDuplicateTo ste stderr+ hSetBuffering stdout bout+ hSetBuffering stderr berr+ readFile' file+++withBuffering :: Handle -> BufferMode -> IO a -> IO a+withBuffering h m act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do+ hSetBuffering h m+ act+++withTempFile :: (FilePath -> IO a) -> IO a+withTempFile act = do+ tmpdir <- getTemporaryDirectory+ bracket+ (openTempFile tmpdir "extra")+ (\(file, h) -> ignore $ removeFile file)+ (\(file, h) -> hClose h >> act file)+++withTempDir :: (FilePath -> IO a) -> IO a+withTempDir act = do+ tmpdir <- getTemporaryDirectory+ bracket+ (createTempDirectory tmpdir "extra")+ (ignore . removeDirectoryRecursive)+ act+++createTempDirectory :: FilePath -> String -> IO FilePath+createTempDirectory dir prefix = do+ -- get the number of seconds during today (including floating point), and grab some interesting digits+ rand :: Integer <- fmap (read . take 20 . filter isDigit . show . utctDayTime) getCurrentTime+ findTempName rand+ where+ findTempName x = do+ let dirpath = dir </> prefix ++ show x+ catchBool isAlreadyExistsError+ (mkPrivateDir dirpath >> return dirpath) $+ \e -> findTempName (x+1)++mkPrivateDir :: String -> IO ()+#ifdef mingw32_HOST_OS+mkPrivateDir s = createDirectory s+#else+mkPrivateDir s = System.Posix.createDirectory s 0o700+#endif
src/System/Info/Extra.hs view
@@ -1,47 +1,47 @@-{-# LANGUAGE CPP #-} - -module System.Info.Extra( - module System.Info, - isWindows, getProcessorCount - ) where - -import System.Info -import System.IO.Unsafe -import Control.Exception.Extra -import System.Environment.Extra -import Foreign.C.Types -import Control.Concurrent -import Data.List - ---------------------------------------------------------------------- --- System.Info - -isWindows :: Bool -#if defined(mingw32_HOST_OS) -isWindows = True -#else -isWindows = False -#endif - - --- Use the underlying GHC function -foreign import ccall getNumberOfProcessors :: IO CInt - - -{-# NOINLINE getProcessorCount #-} -getProcessorCount :: IO Int --- unsafePefromIO so we cache the result and only compute it once -getProcessorCount = let res = unsafePerformIO act in return res - where - act = - if rtsSupportsBoundThreads then - fmap fromIntegral getNumberOfProcessors - else - handle_ (const $ return 1) $ do - env <- lookupEnv "NUMBER_OF_PROCESSORS" - case env of - Just s | [(i,"")] <- reads s -> return i - _ -> do - src <- readFile "/proc/cpuinfo" - return $ length [() | x <- lines src, "processor" `isPrefixOf` x] - +{-# LANGUAGE CPP #-}++module System.Info.Extra(+ module System.Info,+ isWindows, getProcessorCount+ ) where++import System.Info+import System.IO.Unsafe+import Control.Exception.Extra+import System.Environment.Extra+import Foreign.C.Types+import Control.Concurrent+import Data.List++---------------------------------------------------------------------+-- System.Info++isWindows :: Bool+#if defined(mingw32_HOST_OS)+isWindows = True+#else+isWindows = False+#endif+++-- Use the underlying GHC function+foreign import ccall getNumberOfProcessors :: IO CInt+++{-# NOINLINE getProcessorCount #-}+getProcessorCount :: IO Int+-- unsafePefromIO so we cache the result and only compute it once+getProcessorCount = let res = unsafePerformIO act in return res+ where+ act =+ if rtsSupportsBoundThreads then+ fmap fromIntegral getNumberOfProcessors+ else+ handle_ (const $ return 1) $ do+ env <- lookupEnv "NUMBER_OF_PROCESSORS"+ case env of+ Just s | [(i,"")] <- reads s -> return i+ _ -> do+ src <- readFile "/proc/cpuinfo"+ return $ length [() | x <- lines src, "processor" `isPrefixOf` x]+
src/System/Time/Extra.hs view
@@ -1,56 +1,56 @@- -module System.Time.Extra( - sleep, - subtractTime, - showTime, - offsetTime, offsetTimeIncrease, duration - ) where - -import Control.Concurrent -import Data.Time.Clock -import Numeric.Extra -import Data.IORef - - -sleep :: Double -> IO () -sleep x = threadDelay $ ceiling $ x * 1000000 - - -subtractTime :: UTCTime -> UTCTime -> Double -subtractTime end start = fromRational $ toRational $ end `diffUTCTime` start - - -showTime :: Double -> String -showTime 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 ++ m - where (ms,ss) = round x `divMod` 60 - - - --- | Call once at the start, then call repeatedly to get Time values out -offsetTime :: IO (IO Double) -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) -offsetTimeIncrease :: IO (IO Double) -offsetTimeIncrease = do - t <- offsetTime - ref <- newIORef 0 - return $ do - t <- t - atomicModifyIORef ref $ \o -> let m = max t o in m `seq` (m, m) - - -duration :: IO a -> IO (Double, a) -duration act = do - time <- offsetTime - res <- act - time <- time - return (time, res) ++module System.Time.Extra(+ sleep,+ subtractTime,+ showTime,+ offsetTime, offsetTimeIncrease, duration+ ) where++import Control.Concurrent+import Data.Time.Clock+import Numeric.Extra+import Data.IORef+++sleep :: Double -> IO ()+sleep x = threadDelay $ ceiling $ x * 1000000+++subtractTime :: UTCTime -> UTCTime -> Double+subtractTime end start = fromRational $ toRational $ end `diffUTCTime` start+++showTime :: Double -> String+showTime 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 ++ m+ where (ms,ss) = round x `divMod` 60++++-- | Call once at the start, then call repeatedly to get Time values out+offsetTime :: IO (IO Double)+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)+offsetTimeIncrease :: IO (IO Double)+offsetTimeIncrease = do+ t <- offsetTime+ ref <- newIORef 0+ return $ do+ t <- t+ atomicModifyIORef ref $ \o -> let m = max t o in m `seq` (m, m)+++duration :: IO a -> IO (Double, a)+duration act = do+ time <- offsetTime+ res <- act+ time <- time+ return (time, res)
src/Test.hs view
@@ -1,25 +1,27 @@-{-# LANGUAGE ExtendedDefaultRules #-} -module Test(main) where -import TestUtil -import Extra -import Data.List -import Test.QuickCheck -default(Maybe Bool,Int,Double) -main :: IO () -main = do - test "breakOn \"::\" \"a::b::c\" == (\"a\", \"::b::c\")" $ breakOn "::" "a::b::c" == ("a", "::b::c") - test "breakOn \"/\" \"foobar\" == (\"foobar\", \"\")" $ breakOn "/" "foobar" == ("foobar", "") - test "\\needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack" $ \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack - test "breakOnEnd \"::\" \"a::b::c\" == (\"a::b::\", \"c\")" $ breakOnEnd "::" "a::b::c" == ("a::b::", "c") - test "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"] - test "splitOn \"aaa\" \"aaaXaaaXaaaXaaa\" == [\"\",\"X\",\"X\",\"X\",\"\"]" $ splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""] - test "splitOn \"x\" \"x\" == [\"\",\"\"]" $ splitOn "x" "x" == ["",""] - test "splitOn \"x\" \"\" == [\"\"]" $ splitOn "x" "" == [""] - test "\\s x -> s /= \"\" ==> intercalate s (splitOn s x) == x" $ \s x -> s /= "" ==> intercalate s (splitOn s x) == x - test "\\c x -> splitOn [c] x == split (==c) x" $ \c x -> splitOn [c] x == split (==c) x - test "split (=='a') \"aabbaca\" == [\"\",\"\",\"bb\",\"c\",\"\"]" $ split (=='a') "aabbaca" == ["","","bb","c",""] - test "split (=='a') \"\" == [\"\"]" $ split (=='a') "" == [""] - test "stripSuffix \"bar\" \"foobar\" == Just \"foo\"" $ stripSuffix "bar" "foobar" == Just "foo" - test "stripSuffix \"\" \"baz\" == Just \"baz\"" $ stripSuffix "" "baz" == Just "baz" - test "stripSuffix \"foo\" \"quux\" == Nothing" $ stripSuffix "foo" "quux" == Nothing - putStrLn "Success" +{-# LANGUAGE ExtendedDefaultRules #-}+module Test(main) where+import TestUtil+import Extra+import Data.List+import Test.QuickCheck+default(Maybe Bool,Int,Double)+main :: IO ()+main = do+ test "Just False &&^ undefined == Just False" $ Just False &&^ undefined == Just False+ test "Just True &&^ Just True == Just True" $ Just True &&^ Just True == Just True+ test "breakOn \"::\" \"a::b::c\" == (\"a\", \"::b::c\")" $ breakOn "::" "a::b::c" == ("a", "::b::c")+ test "breakOn \"/\" \"foobar\" == (\"foobar\", \"\")" $ breakOn "/" "foobar" == ("foobar", "")+ test "\\needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack" $ \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack+ test "breakOnEnd \"::\" \"a::b::c\" == (\"a::b::\", \"c\")" $ breakOnEnd "::" "a::b::c" == ("a::b::", "c")+ test "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"]+ test "splitOn \"aaa\" \"aaaXaaaXaaaXaaa\" == [\"\",\"X\",\"X\",\"X\",\"\"]" $ splitOn "aaa" "aaaXaaaXaaaXaaa" == ["","X","X","X",""]+ test "splitOn \"x\" \"x\" == [\"\",\"\"]" $ splitOn "x" "x" == ["",""]+ test "splitOn \"x\" \"\" == [\"\"]" $ splitOn "x" "" == [""]+ test "\\s x -> s /= \"\" ==> intercalate s (splitOn s x) == x" $ \s x -> s /= "" ==> intercalate s (splitOn s x) == x+ test "\\c x -> splitOn [c] x == split (==c) x" $ \c x -> splitOn [c] x == split (==c) x+ test "split (=='a') \"aabbaca\" == [\"\",\"\",\"bb\",\"c\",\"\"]" $ split (=='a') "aabbaca" == ["","","bb","c",""]+ test "split (=='a') \"\" == [\"\"]" $ split (=='a') "" == [""]+ test "stripSuffix \"bar\" \"foobar\" == Just \"foo\"" $ stripSuffix "bar" "foobar" == Just "foo"+ test "stripSuffix \"\" \"baz\" == Just \"baz\"" $ stripSuffix "" "baz" == Just "baz"+ test "stripSuffix \"foo\" \"quux\" == Nothing" $ stripSuffix "foo" "quux" == Nothing+ putStrLn "Success"
src/TestUtil.hs view
@@ -1,11 +1,11 @@-module TestUtil(test) where - -import Test.QuickCheck -import Test.QuickCheck.Test hiding (test) -import Control.Monad - -test :: Testable prop => String -> prop -> IO () -test msg prop = do - putStrLn msg - r <- quickCheckResult prop - unless (isSuccess r) $ error "Test failed" +module TestUtil(test) where++import Test.QuickCheck+import Test.QuickCheck.Test hiding (test)+import Control.Monad++test :: Testable prop => String -> prop -> IO ()+test msg prop = do+ putStrLn msg+ r <- quickCheckResult prop+ unless (isSuccess r) $ error "Test failed"