1{- misc utility functions 2 - 3 - Copyright 2010-2011 Joey Hess <id@joeyh.name> 4 - 5 - License: BSD-2-clause 6 -} 7 8{-# OPTIONS_GHC -fno-warn-tabs #-} 9 10module Utility.Misc ( 11 hGetContentsStrict, 12 readFileStrict, 13 separate, 14 separate', 15 firstLine, 16 firstLine', 17 segment, 18 segmentDelim, 19 massReplace, 20 hGetSomeString, 21 exitBool, 22 23 prop_segment_regressionTest, 24) where 25 26import System.IO 27import Control.Monad 28import Foreign 29import Data.Char 30import Data.List 31import System.Exit 32import Control.Applicative 33import qualified Data.ByteString as S 34import Prelude 35 36{- A version of hgetContents that is not lazy. Ensures file is 37 - all read before it gets closed. -} 38hGetContentsStrict :: Handle -> IO String 39hGetContentsStrict = hGetContents >=> \s -> length s `seq` return s 40 41{- A version of readFile that is not lazy. -} 42readFileStrict :: FilePath -> IO String 43readFileStrict = readFile >=> \s -> length s `seq` return s 44 45{- Like break, but the item matching the condition is not included 46 - in the second result list. 47 - 48 - separate (== ':') "foo:bar" = ("foo", "bar") 49 - separate (== ':') "foobar" = ("foobar", "") 50 -} 51separate :: (a -> Bool) -> [a] -> ([a], [a]) 52separate c l = unbreak $ break c l 53 where 54 unbreak r@(a, b) 55 | null b = r 56 | otherwise = (a, tail b) 57 58separate' :: (Word8 -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) 59separate' c l = unbreak $ S.break c l 60 where 61 unbreak r@(a, b) 62 | S.null b = r 63 | otherwise = (a, S.tail b) 64 65{- Breaks out the first line. -} 66firstLine :: String -> String 67firstLine = takeWhile (/= '\n') 68 69firstLine' :: S.ByteString -> S.ByteString 70firstLine' = S.takeWhile (/= nl) 71 where 72 nl = fromIntegral (ord '\n') 73 74{- Splits a list into segments that are delimited by items matching 75 - a predicate. (The delimiters are not included in the segments.) 76 - Segments may be empty. -} 77segment :: (a -> Bool) -> [a] -> [[a]] 78segment p l = map reverse $ go [] [] l 79 where 80 go c r [] = reverse $ c:r 81 go c r (i:is) 82 | p i = go [] (c:r) is 83 | otherwise = go (i:c) r is 84 85prop_segment_regressionTest :: Bool 86prop_segment_regressionTest = all id 87 -- Even an empty list is a segment. 88 [ segment (== "--") [] == [[]] 89 -- There are two segements in this list, even though the first is empty. 90 , segment (== "--") ["--", "foo", "bar"] == [[],["foo","bar"]] 91 ] 92 93{- Includes the delimiters as segments of their own. -} 94segmentDelim :: (a -> Bool) -> [a] -> [[a]] 95segmentDelim p l = map reverse $ go [] [] l 96 where 97 go c r [] = reverse $ c:r 98 go c r (i:is) 99 | p i = go [] ([i]:c:r) is 100 | otherwise = go (i:c) r is 101 102{- Replaces multiple values in a string. 103 - 104 - Takes care to skip over just-replaced values, so that they are not 105 - mangled. For example, massReplace [("foo", "new foo")] does not 106 - replace the "new foo" with "new new foo". 107 -} 108massReplace :: [(String, String)] -> String -> String 109massReplace vs = go [] vs 110 where 111 112 go acc _ [] = concat $ reverse acc 113 go acc [] (c:cs) = go ([c]:acc) vs cs 114 go acc ((val, replacement):rest) s 115 | val `isPrefixOf` s = 116 go (replacement:acc) vs (drop (length val) s) 117 | otherwise = go acc rest s 118 119{- Wrapper around hGetBufSome that returns a String. 120 - 121 - The null string is returned on eof, otherwise returns whatever 122 - data is currently available to read from the handle, or waits for 123 - data to be written to it if none is currently available. 124 - 125 - Note on encodings: The normal encoding of the Handle is ignored; 126 - each byte is converted to a Char. Not unicode clean! 127 -} 128hGetSomeString :: Handle -> Int -> IO String 129hGetSomeString h sz = do 130 fp <- mallocForeignPtrBytes sz 131 len <- withForeignPtr fp $ \buf -> hGetBufSome h buf sz 132 map (chr . fromIntegral) <$> withForeignPtr fp (peekbytes len) 133 where 134 peekbytes :: Int -> Ptr Word8 -> IO [Word8] 135 peekbytes len buf = mapM (peekElemOff buf) [0..pred len] 136 137exitBool :: Bool -> IO a 138exitBool False = exitFailure 139exitBool True = exitSuccess 140