1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
{- misc utility functions
-
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Utility.Misc where
import System.IO
import Control.Monad
import Foreign
import Data.Char
import Data.List
import Control.Applicative
import System.Exit
#ifndef mingw32_HOST_OS
import System.Posix.Process (getAnyProcessStatus)
import Utility.Exception
#endif
import Utility.FileSystemEncoding
import Utility.Monad
{- 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
{- Reads a file strictly, and using the FileSystemEncoding, so it will
- never crash on a badly encoded file. -}
readFileStrictAnyEncoding :: FilePath -> IO String
readFileStrictAnyEncoding f = withFile f ReadMode $ \h -> do
fileEncoding h
hClose h `after` hGetContentsStrict h
{- Writes a file, using the FileSystemEncoding so it will never crash
- on a badly encoded content string. -}
writeFileAnyEncoding :: FilePath -> String -> IO ()
writeFileAnyEncoding f content = withFile f WriteMode $ \h -> do
fileEncoding h
hPutStr h content
{- 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 = do
-- 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
|
