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