{- misc utility functions - - Copyright 2010-2011 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Misc where import System.IO import Control.Monad import Foreign import Data.Char import Data.List import System.Exit #ifndef mingw32_HOST_OS import System.Posix.Process (getAnyProcessStatus) import Utility.Exception #endif import Control.Applicative import Prelude {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} hGetContentsStrict :: Handle -> IO String hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s {- A version of readFile that is not lazy. -} readFileStrict :: FilePath -> IO String readFileStrict = readFile >=> \s -> length s `seq` return s {- Like break, but the item matching the condition is not included - in the second result list. - - separate (== ':') "foo:bar" = ("foo", "bar") - separate (== ':') "foobar" = ("foobar", "") -} separate :: (a -> Bool) -> [a] -> ([a], [a]) separate c l = unbreak $ break c l where unbreak r@(a, b) | null b = r | otherwise = (a, tail b) {- Breaks out the first line. -} firstLine :: String -> String firstLine = takeWhile (/= '\n') {- Splits a list into segments that are delimited by items matching - a predicate. (The delimiters are not included in the segments.) - Segments may be empty. -} segment :: (a -> Bool) -> [a] -> [[a]] segment p l = map reverse $ go [] [] l where go c r [] = reverse $ c:r go c r (i:is) | p i = go [] (c:r) is | otherwise = go (i:c) r is prop_segment_regressionTest :: Bool prop_segment_regressionTest = all id -- Even an empty list is a segment. [ segment (== "--") [] == [[]] -- There are two segements in this list, even though the first is empty. , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]] ] {- Includes the delimiters as segments of their own. -} segmentDelim :: (a -> Bool) -> [a] -> [[a]] segmentDelim p l = map reverse $ go [] [] l where go c r [] = reverse $ c:r go c r (i:is) | p i = go [] ([i]:c:r) is | otherwise = go (i:c) r is {- Replaces multiple values in a string. - - Takes care to skip over just-replaced values, so that they are not - mangled. For example, massReplace [("foo", "new foo")] does not - replace the "new foo" with "new new foo". -} massReplace :: [(String, String)] -> String -> String massReplace vs = go [] vs where go acc _ [] = concat $ reverse acc go acc [] (c:cs) = go ([c]:acc) vs cs go acc ((val, replacement):rest) s | val `isPrefixOf` s = go (replacement:acc) vs (drop (length val) s) | otherwise = go acc rest s {- Wrapper around hGetBufSome that returns a String. - - The null string is returned on eof, otherwise returns whatever - data is currently available to read from the handle, or waits for - data to be written to it if none is currently available. - - Note on encodings: The normal encoding of the Handle is ignored; - each byte is converted to a Char. Not unicode clean! -} hGetSomeString :: Handle -> Int -> IO String hGetSomeString h sz = do fp <- mallocForeignPtrBytes sz len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len) where peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] {- Reaps any zombie git processes. - - Warning: Not thread safe. Anything that was expecting to wait - on a process and get back an exit status is going to be confused - if this reap gets there first. -} reapZombies :: IO () #ifndef mingw32_HOST_OS reapZombies = -- throws an exception when there are no child processes catchDefaultIO Nothing (getAnyProcessStatus False True) >>= maybe (return ()) (const reapZombies) #else reapZombies = return () #endif exitBool :: Bool -> IO a exitBool False = exitFailure exitBool True = exitSuccess