Util.lhs 26.2 KB
 partain committed Jan 08, 1996 1 %  Simon Marlow committed Oct 11, 2006 2 % (c) The University of Glasgow 2006  simonmar committed Aug 29, 2002 3 % (c) The University of Glasgow 1992-2002  partain committed Jan 08, 1996 4 5 6 7 8 % \section[Util]{Highly random utility functions} \begin{code} module Util (  sof committed May 18, 1997 9   partain committed Jan 08, 1996 10  -- general list processing  partain committed Mar 19, 1996 11  zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,  simonpj committed Mar 23, 2000 12  zipLazy, stretchZipWith,  simonpj committed Apr 04, 2005 13  mapFst, mapSnd,  partain committed May 17, 1996 14  mapAndUnzip, mapAndUnzip3,  simonpj@microsoft.com committed Jan 02, 2007 15  nOfThem, filterOut, partitionWith, splitEithers,  16 17 18 19  lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, equalLength, compareLength,  simonpj committed Jul 19, 2005 20  isSingleton, only, singleton,  simonpj committed Nov 11, 2002 21  notNull, snocView,  sof committed Apr 05, 2002 22   partain committed Jan 08, 1996 23 24  isIn, isn'tIn,  simonpj committed Mar 23, 2000 25 26 27  -- for-loop nTimes,  partain committed Jan 08, 1996 28  -- sorting  simonpj committed Dec 22, 2004 29  sortLe, sortWith,  partain committed Jan 08, 1996 30 31 32 33 34  -- transitive closures transitiveClosure, -- accumulating  simonpj committed Nov 16, 2005 35  foldl2, count, all2,  sof committed Oct 25, 2001 36   simonmar committed Mar 18, 2005 37  takeList, dropList, splitAtList, split,  partain committed Jan 08, 1996 38 39  -- comparisons  40  isEqual, eqListBy,  Ian Lynagh committed Jul 02, 2007 41  thenCmp, cmpList, maybePrefixMatch,  simonmar committed Mar 18, 2005 42  removeSpaces,  partain committed May 17, 1996 43   simonm committed Mar 04, 1999 44  -- strictness  Ian Lynagh committed Jul 06, 2007 45  seqList,  simonm committed Mar 04, 1999 46   partain committed Jan 08, 1996 47  -- pairs  simonmar committed Aug 29, 2002 48  unzipWith,  simonmar committed Jun 03, 1999 49   simonmar committed Mar 18, 2005 50  global, consIORef,  simonmar committed Oct 15, 2002 51 52 53  -- module names looksLikeModuleName,  sof committed Feb 13, 2003 54   simonmar committed Aug 13, 2004 55 56 57 58  toArgs, -- Floating point stuff readRational,  simonmar committed Mar 18, 2005 59 60 61 62  -- IO-ish utilities createDirectoryHierarchy, doesDirNameExist,  simonmar committed Mar 24, 2005 63  modificationTimeIfExists,  simonmar committed Mar 18, 2005 64 65 66 67 68  later, handleDyn, handle, -- Filename utils Suffix,  simonmar committed May 17, 2005 69  splitFilename, suffixOf, basenameOf, joinFileExt,  simonmar committed May 17, 2005 70  splitFilenameDir, joinFileName,  simonmar committed May 17, 2005 71 72  splitFilename3, splitLongestPrefix,  simonmar committed Mar 18, 2005 73 74 75  replaceFilenameSuffix, directoryOf, filenameOf, replaceFilenameDirectory, escapeSpaces, isPathSeparator,  simonmar committed Nov 04, 2005 76  parseSearchPath,  simonmar committed Mar 21, 2005 77  normalisePath, platformPath, pgmPath,  partain committed Jan 08, 1996 78 79  ) where  simonm committed Jan 08, 1998 80 81 #include "HsVersions.h"  simonpj committed Jan 04, 2002 82 import Panic ( panic, trace )  simonmar committed Oct 12, 2000 83 import FastTypes  simonmar committed Aug 29, 2002 84   Simon Marlow committed Oct 11, 2006 85 86 87 88 89 90 import Control.Exception ( Exception(..), finally, catchDyn, throw ) import qualified Control.Exception as Exception import Data.Dynamic ( Typeable ) import Data.IORef ( IORef, newIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef ( readIORef, writeIORef )  simonmar committed Aug 29, 2002 91   Simon Marlow committed Oct 11, 2006 92 import qualified Data.List as List ( elem, notElem )  simonmar committed Aug 29, 2002 93 94  #ifndef DEBUG  Simon Marlow committed Oct 11, 2006 95 import Data.List ( zipWith4 )  sewardj committed Oct 27, 2000 96 #endif  sof committed May 28, 2001 97   Simon Marlow committed Oct 11, 2006 98 99 100 101 102 103 104 import Control.Monad ( when ) import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError ) import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) import Data.Ratio ( (%) ) import System.Time ( ClockTime )  simonmar committed Oct 15, 2002 105   partain committed May 16, 1996 106 infixr 9 thenCmp  partain committed Jan 08, 1996 107 108 \end{code}  simonpj committed Mar 23, 2000 109 110 111 112 113 114 115 116 117 118 119 120 121 122 %************************************************************************ %* * \subsection{A for loop} %* * %************************************************************************ \begin{code} -- Compose a function with itself n times. (nth rather than twice) nTimes :: Int -> (a -> a) -> (a -> a) nTimes 0 _ = id nTimes 1 f = f nTimes n f = f . nTimes (n-1) f \end{code}  partain committed Jan 08, 1996 123 124 125 126 127 128 %************************************************************************ %* * \subsection[Utils-lists]{General list processing} %* * %************************************************************************  simonmar committed Aug 13, 2004 129 130 131 132 133 134 \begin{code} filterOut :: (a->Bool) -> [a] -> [a] -- Like filter, only reverses the sense of the test filterOut p [] = [] filterOut p (x:xs) | p x = filterOut p xs | otherwise = x : filterOut p xs  simonpj@microsoft.com committed Nov 10, 2006 135 136 137 138 139 140 141 142 143  partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) partitionWith f [] = ([],[]) partitionWith f (x:xs) = case f x of Left b -> (b:bs, cs) Right c -> (bs, c:cs) where (bs,cs) = partitionWith f xs  simonpj@microsoft.com committed Jan 02, 2007 144 145 146 147 148 149 150 splitEithers :: [Either a b] -> ([a], [b]) splitEithers [] = ([],[]) splitEithers (e : es) = case e of Left x -> (x:xs, ys) Right y -> (xs, y:ys) where (xs,ys) = splitEithers es  simonmar committed Aug 13, 2004 151 152 \end{code}  partain committed Mar 19, 1996 153 154 155 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not?  partain committed Jan 08, 1996 156 157  \begin{code}  partain committed May 16, 1996 158 159 160 161 zipEqual :: String -> [a] -> [b] -> [(a,b)] zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]  partain committed Jan 08, 1996 162 163  #ifndef DEBUG  partain committed May 16, 1996 164 165 166 167 zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = zipWith4  partain committed Jan 08, 1996 168 #else  partain committed May 16, 1996 169 170 zipEqual msg [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs  simonpj committed May 18, 1999 171 zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)  partain committed May 16, 1996 172 173 174  zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs zipWithEqual msg _ [] [] = []  simonpj committed May 18, 1999 175 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)  partain committed May 16, 1996 176 177 178 179  zipWith3Equal msg z (a:as) (b:bs) (c:cs) = z a b c : zipWith3Equal msg z as bs cs zipWith3Equal msg _ [] [] [] = []  simonpj committed May 18, 1999 180 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)  partain committed May 16, 1996 181 182 183 184  zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) = z a b c d : zipWith4Equal msg z as bs cs ds zipWith4Equal msg _ [] [] [] [] = []  simonpj committed May 18, 1999 185 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)  partain committed Jan 08, 1996 186 187 188 #endif \end{code}  partain committed Mar 19, 1996 189 190 191 192 193 194 195 196 \begin{code} -- zipLazy is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] ys = [] zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys \end{code}  simonm committed Dec 02, 1998 197 198  \begin{code}  simonpj committed Mar 23, 2000 199 200 201 202 203 204 205 206 207 208 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] -- (stretchZipWith p z f xs ys) stretches ys by inserting z in -- the places where p returns *True* stretchZipWith p z f [] ys = [] stretchZipWith p z f (x:xs) ys | p x = f x z : stretchZipWith p z f xs ys | otherwise = case ys of [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys  simonm committed Dec 02, 1998 209 210 211 \end{code}  partain committed Apr 30, 1996 212 \begin{code}  simonpj committed Apr 04, 2005 213 214 215 216 217 218 mapFst :: (a->c) -> [(a,b)] -> [(c,b)] mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] mapFst f xys = [(f x, y) | (x,y) <- xys] mapSnd f xys = [(x, f y) | (x,y) <- xys]  partain committed Apr 30, 1996 219 220 221 222 223 224 225 226 227 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) mapAndUnzip f [] = ([],[]) mapAndUnzip f (x:xs) = let (r1, r2) = f x (rs1, rs2) = mapAndUnzip f xs in (r1:rs1, r2:rs2)  partain committed May 17, 1996 228 229 230 231 232 233 234 235 236 237  mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) mapAndUnzip3 f [] = ([],[],[]) mapAndUnzip3 f (x:xs) = let (r1, r2, r3) = f x (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3)  partain committed Apr 30, 1996 238 239 \end{code}  partain committed Jan 08, 1996 240 241 \begin{code} nOfThem :: Int -> a -> [a]  sof committed Mar 01, 1999 242 nOfThem n thing = replicate n thing  partain committed Jan 08, 1996 243   sof committed Oct 25, 2001 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n'; -- specification: -- -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred n -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) -- atLength :: ([a] -> b) -> (Int -> b) -> [a] -> Int -> b atLength atLenPred atEndPred ls n | n < 0 = atEndPred n | otherwise = go n ls where go n [] = atEndPred n go 0 ls = atLenPred ls go n (_:xs) = go (n-1) xs -- special cases.  partain committed Jan 08, 1996 266 lengthExceeds :: [a] -> Int -> Bool  simonpj committed Mar 25, 2002 267 -- (lengthExceeds xs n) = (length xs > n)  sof committed Apr 05, 2002 268 lengthExceeds = atLength notNull (const False)  sof committed Oct 25, 2001 269 270  lengthAtLeast :: [a] -> Int -> Bool  sof committed Apr 05, 2002 271 lengthAtLeast = atLength notNull (== 0)  sof committed Oct 25, 2001 272 273 274 275 276 277 278 279 280 281 282 283 284 285  lengthIs :: [a] -> Int -> Bool lengthIs = atLength null (==0) listLengthCmp :: [a] -> Int -> Ordering listLengthCmp = atLength atLen atEnd where atEnd 0 = EQ atEnd x | x > 0 = LT -- not yet seen 'n' elts, so list length is < n. | otherwise = GT atLen [] = EQ atLen _ = GT  partain committed Jan 08, 1996 286   simonpj@microsoft.com committed Aug 15, 2006 287 288 289 290 291 292 293 294 295 296 297 298 equalLength :: [a] -> [b] -> Bool equalLength [] [] = True equalLength (_:xs) (_:ys) = equalLength xs ys equalLength xs ys = False compareLength :: [a] -> [b] -> Ordering compareLength [] [] = EQ compareLength (_:xs) (_:ys) = compareLength xs ys compareLength [] _ys = LT compareLength _xs [] = GT ----------------------------  simonpj committed Jul 19, 2005 299 300 301 singleton :: a -> [a] singleton x = [x]  partain committed Jan 08, 1996 302 303 304 isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False  simonm committed Apr 27, 1999 305   sof committed Apr 05, 2002 306 307 308 309 notNull :: [a] -> Bool notNull [] = False notNull _ = True  simonm committed Apr 27, 1999 310 311 312 313 314 315 only :: [a] -> a #ifdef DEBUG only [a] = a #else only (a:_) = a #endif  partain committed Jan 08, 1996 316 317 318 \end{code} Debugging/specialising versions of \tr{elem} and \tr{notElem}  simonm committed Jan 08, 1998 319   partain committed Jan 08, 1996 320 321 322 323 324 325 326 327 328 329 330 331 332 333 \begin{code} isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool # ifndef DEBUG isIn msg x ys = elem__ x ys isn'tIn msg x ys = notElem__ x ys --these are here to be SPECIALIZEd (automagically) elem__ _ [] = False elem__ x (y:ys) = x==y || elem__ x ys notElem__ x [] = True notElem__ x (y:ys) = x /= y && notElem__ x ys  ross committed Jun 08, 2003 334 # else /* DEBUG */  partain committed Jan 08, 1996 335 isIn msg x ys  simonmar committed Oct 12, 2000 336  = elem (_ILIT 0) x ys  partain committed Jan 08, 1996 337 338 339  where elem i _ [] = False elem i x (y:ys)  simonpj committed Jan 04, 2002 340 341 342  | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $x List.elem (y:ys) | otherwise = x == y || elem (i +# _ILIT(1)) x ys  partain committed Jan 08, 1996 343 344  isn'tIn msg x ys  simonmar committed Oct 12, 2000 345  = notElem (_ILIT 0) x ys  partain committed Jan 08, 1996 346 347 348  where notElem i x [] = True notElem i x (y:ys)  simonpj committed Jan 04, 2002 349 350 351  | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg)$ x List.notElem (y:ys) | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys  ross committed Jun 08, 2003 352 # endif /* DEBUG */  partain committed Jan 08, 1996 353 354 355 356 357 358 359 360 361 362 363 364 365 366 \end{code} %************************************************************************ %* * \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} %* * %************************************************************************ \begin{display} Date: Mon, 3 May 93 20:45:23 +0200 From: Carsten Kehler Holst To: partain@dcs.gla.ac.uk Subject: natural merge sort beats quick sort [ and it is prettier ]  partain committed Mar 19, 1996 367 Here is a piece of Haskell code that I'm rather fond of. See it as an  partain committed Jan 11, 1996 368 369 attempt to get rid of the ridiculous quick-sort routine. group is quite useful by itself I think it was John's idea originally though I  partain committed Jan 08, 1996 370 believe the lazy version is due to me [surprisingly complicated].  partain committed Jan 11, 1996 371 372 gamma [used to be called] is called gamma because I got inspired by the Gamma calculus. It is not very close to the calculus but does  partain committed Mar 19, 1996 373 374 375 behave less sequentially than both foldr and foldl. One could imagine a version of gamma that took a unit element as well thereby avoiding the problem with empty lists.  partain committed Jan 08, 1996 376 377 378 379 380 381  I've tried this code against 1) insertion sort - as provided by haskell 2) the normal implementation of quick sort 3) a deforested version of quick sort due to Jan Sparud  partain committed Jan 22, 1996 382  4) a super-optimized-quick-sort of Lennart's  partain committed Jan 08, 1996 383 384 385 386  If the list is partially sorted both merge sort and in particular natural merge sort wins. If the list is random [ average length of rising subsequences = approx 2 ] mergesort still wins and natural  partain committed Jan 22, 1996 387 merge sort is marginally beaten by Lennart's soqs. The space  partain committed Jan 11, 1996 388 consumption of merge sort is a bit worse than Lennart's quick sort  partain committed Jan 08, 1996 389 390 391 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his fpca article ] isn't used because of group.  partain committed Mar 19, 1996 392 have fun  partain committed Jan 08, 1996 393 394 395 396 397 Carsten \end{display} \begin{code} group :: (a -> a -> Bool) -> [a] -> [[a]]  simonpj committed Oct 01, 2004 398 399 400 401 402 403 404 -- Given a <= function, group finds maximal contiguous up-runs -- or down-runs in the input list. -- It's stable, in the sense that it never re-orders equal elements -- -- Date: Mon, 12 Feb 1996 15:09:41 +0000 -- From: Andy Gill -- Here is a better' definition of group.  partain committed Jan 11, 1996 405   partain committed Mar 19, 1996 406 407 408 409 410 group p [] = [] group p (x:xs) = group' xs x x (x :) where group' [] _ _ s = [s []] group' (x:xs) x_min x_max s  simonpj committed Oct 01, 2004 411 412  | x_max p x = group' xs x_min x (s . (x :)) | not (x_min p x) = group' xs x x_max ((x :) . s)  partain committed Mar 19, 1996 413  | otherwise = s [] : group' xs x x (x :)  simonpj committed Oct 01, 2004 414 415  -- NB: the 'not' is essential for stablity -- x p x_min would reverse equal elements  partain committed Jan 08, 1996 416 417 418 419  generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] generalMerge p xs [] = xs generalMerge p [] ys = ys  partain committed Jan 11, 1996 420 generalMerge p (x:xs) (y:ys) | x p y = x : generalMerge p xs (y:ys)  partain committed Mar 19, 1996 421  | otherwise = y : generalMerge p (x:xs) ys  partain committed Jan 08, 1996 422 423 424 425 426 427 428 429 430 431 432 433  -- gamma is now called balancedFold balancedFold :: (a -> a -> a) -> [a] -> a balancedFold f [] = error "can't reduce an empty list using balancedFold" balancedFold f [x] = x balancedFold f l = balancedFold f (balancedFold' f l) balancedFold' :: (a -> a -> a) -> [a] -> [a] balancedFold' f (x:y:xs) = f x y : balancedFold' f xs balancedFold' f xs = xs  partain committed Jan 11, 1996 434 435 generalNaturalMergeSort p [] = [] generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs  partain committed Jan 08, 1996 436   simonmar committed Aug 29, 2002 437 #if NOT_USED  simonpj committed Oct 09, 2003 438 439 440 generalMergeSort p [] = [] generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs  partain committed Jan 08, 1996 441 442 443 444 445 446 mergeSort, naturalMergeSort :: Ord a => [a] -> [a] mergeSort = generalMergeSort (<=) naturalMergeSort = generalNaturalMergeSort (<=) mergeSortLe le = generalMergeSort le  simonmar committed Aug 29, 2002 447 448 #endif  simonpj committed Aug 17, 2004 449 450 sortLe :: (a->a->Bool) -> [a] -> [a] sortLe le = generalNaturalMergeSort le  simonpj committed Dec 22, 2004 451 452 453 454 455  sortWith :: Ord b => (a->b) -> [a] -> [a] sortWith get_key xs = sortLe le xs where x le y = get_key x < get_key y  partain committed Jan 08, 1996 456 457 458 459 460 461 462 463 464 465 466 467 468 \end{code} %************************************************************************ %* * \subsection[Utils-transitive-closure]{Transitive closure} %* * %************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. \begin{code} transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate  partain committed Mar 19, 1996 469  -> [a]  partain committed Jan 08, 1996 470 471 472  -> [a] -- The transitive closure transitiveClosure succ eq xs  partain committed Jun 05, 1996 473  = go [] xs  partain committed Jan 08, 1996 474  where  partain committed Jun 05, 1996 475 476 477  go done [] = done go done (x:xs) | x is_in done = go done xs | otherwise = go (x:done) (succ x ++ xs)  partain committed Jan 08, 1996 478 479 480 481 482 483 484 485 486 487 488 489  x is_in [] = False x is_in (y:ys) | eq x y = True | otherwise = x is_in ys \end{code} %************************************************************************ %* * \subsection[Utils-accum]{Accumulating} %* * %************************************************************************  simonpj committed May 18, 1999 490 491 492 493 494 495 A combination of foldl with zip. It works with equal length lists. \begin{code} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc foldl2 k z [] [] = z foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs  simonpj committed Nov 16, 2005 496 497 498 499 500 501 502  all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool -- True if the lists are the same length, and -- all corresponding elements satisfy the predicate all2 p [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 p xs ys = False  simonpj committed May 18, 1999 503 504 505 506 507 508 509 510 511 512 513 \end{code} Count the number of times a predicate is true \begin{code} count :: (a -> Bool) -> [a] -> Int count p [] = 0 count p (x:xs) | p x = 1 + count p xs | otherwise = count p xs \end{code}  sof committed Oct 25, 2001 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: \begin{code} takeList :: [b] -> [a] -> [a] takeList [] _ = [] takeList (_:xs) ls = case ls of [] -> [] (y:ys) -> y : takeList xs ys dropList :: [b] -> [a] -> [a] dropList [] xs = xs dropList _ xs@[] = xs dropList (_:xs) (_:ys) = dropList xs ys splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList [] xs = ([], xs) splitAtList _ xs@[] = (xs, xs) splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys  simonpj@microsoft.com committed Sep 23, 2006 538 539 540 541 542 543 544 545 546 snocView :: [a] -> Maybe ([a],a) -- Split off the last element snocView [] = Nothing snocView xs = go [] xs where -- Invariant: second arg is non-empty go acc [x] = Just (reverse acc, x) go acc (x:xs) = go (x:acc) xs  simonmar committed Mar 18, 2005 547 548 549 550 551 split :: Char -> String -> [String] split c s = case rest of [] -> [chunk] _:rest -> chunk : split c rest where (chunk, rest) = break (==c) s  sof committed Oct 25, 2001 552 553 \end{code}  simonpj committed May 18, 1999 554   partain committed Jan 08, 1996 555 556 557 558 559 560 %************************************************************************ %* * \subsection[Utils-comparison]{Comparisons} %* * %************************************************************************  partain committed Mar 19, 1996 561 \begin{code}  simonpj committed Dec 20, 2004 562 563 564 565 566 567 568 569 570 571 572 isEqual :: Ordering -> Bool -- Often used in (isEqual (a compare b)) isEqual GT = False isEqual EQ = True isEqual LT = False thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} thenCmp EQ any = any thenCmp other any = other  simonpj committed Jul 19, 2001 573 574 575 576 577 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool eqListBy eq [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys eqListBy eq xs ys = False  simonm committed Jan 08, 1998 578 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering  partain committed Mar 19, 1996 579 580  -- cmpList' uses a user-specified comparer  simonm committed Jan 08, 1998 581 582 583 cmpList cmp [] [] = EQ cmpList cmp [] _ = LT cmpList cmp _ [] = GT  partain committed Mar 19, 1996 584 cmpList cmp (a:as) (b:bs)  simonm committed Jan 08, 1998 585  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }  partain committed Mar 19, 1996 586 587 \end{code}  partain committed Jan 08, 1996 588 \begin{code}  simonmar committed Aug 20, 2003 589 590 591 592 593 594 595 maybePrefixMatch :: String -> String -> Maybe String maybePrefixMatch [] rest = Just rest maybePrefixMatch (_:_) [] = Nothing maybePrefixMatch (p:pat) (r:rest) | p == r = maybePrefixMatch pat rest | otherwise = Nothing  simonmar committed Mar 18, 2005 596 597 removeSpaces :: String -> String removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace  partain committed Jan 08, 1996 598 599 600 601 602 603 604 605 606 607 608 609 610 \end{code} %************************************************************************ %* * \subsection[Utils-pairs]{Pairs} %* * %************************************************************************ \begin{code} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs \end{code}  simonm committed Mar 04, 1999 611 612 613 614 \begin{code} seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x seq seqList xs b  simonmar committed Jun 01, 1999 615 \end{code}  simonmar committed Oct 11, 2000 616 617 618 619 620 621 622  Global variables: \begin{code} global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code}  simonmar committed Oct 15, 2002 623   simonmar committed Mar 18, 2005 624 625 626 627 628 629 630 \begin{code} consIORef :: IORef [a] -> a -> IO () consIORef var x = do xs <- readIORef var writeIORef var (x:xs) \end{code}  simonmar committed Oct 15, 2002 631 632 633 Module names: \begin{code}  Ian Lynagh committed Jul 02, 2007 634 looksLikeModuleName :: String -> Bool  simonmar committed Oct 15, 2002 635 looksLikeModuleName [] = False  simonmar committed Jan 09, 2003 636 637 638 639 looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True go ('.':cs) = looksLikeModuleName cs go (c:cs) = (isAlphaNum c || c == '_') && go cs  simonmar committed Oct 15, 2002 640 \end{code}  sof committed Feb 13, 2003 641   rjmccall@gmail.com committed Sep 17, 2006 642 643 644 645 Akin to @Prelude.words@, but acts like the Bourne shell, treating quoted strings and escaped characters within the input as solid blocks of characters. Doesn't raise any exceptions on malformed escapes or quoting.  sof committed Feb 13, 2003 646 647 648 649 650  \begin{code} toArgs :: String -> [String] toArgs "" = [] toArgs s =  rjmccall@gmail.com committed Sep 17, 2006 651 652 653  case dropWhile isSpace s of -- drop initial spacing [] -> [] -- empty, so no more tokens rem -> let (tok,aft) = token rem [] in tok : toArgs aft  sof committed Feb 13, 2003 654  where  rjmccall@gmail.com committed Sep 17, 2006 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680  -- Grab a token off the string, given that the first character exists and -- isn't whitespace. The second argument is an accumulator which has to be -- reversed at the end. token [] acc = (reverse acc,[]) -- out of characters token ('\\':c:aft) acc -- escapes = token aft ((escape c) : acc) token (q:aft) acc | q == '"' || q == '\'' -- open quotes = let (aft',acc') = quote q aft acc in token aft' acc' token (c:aft) acc | isSpace c -- unescaped, unquoted spacing = (reverse acc,aft) token (c:aft) acc -- anything else goes in the token = token aft (c:acc) -- Get the appropriate character for a single-character escape. escape 'n' = '\n' escape 't' = '\t' escape 'r' = '\r' escape c = c -- Read into accumulator until a quote character is found. quote qc = let quote' [] acc = ([],acc) quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc) quote' (c:aft) acc | c == qc = (aft,acc) quote' (c:aft) acc = quote' aft (c:acc) in quote'  sof committed Feb 13, 2003 681 \end{code}  simonmar committed Aug 13, 2004 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730  -- ----------------------------------------------------------------------------- -- Floats \begin{code} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" readRational__ r = do (n,d,s) <- readFix r (k,t) <- readExp s return ((n%1)*10^^(k-d), t) where readFix r = do (ds,s) <- lexDecDigits r (ds',t) <- lexDotDigits s return (read (ds++ds'), length ds', t) readExp (e:s) | e elem "eE" = readExp' s readExp s = return (0,s) readExp' ('+':s) = readDec s readExp' ('-':s) = do (k,t) <- readDec s return (-k,t) readExp' s = readDec s readDec s = do (ds,r) <- nonnull isDigit s return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], r) lexDecDigits = nonnull isDigit lexDotDigits ('.':s) = return (span isDigit s) lexDotDigits s = return ("",s) nonnull p s = do (cs@(_:_),t) <- return (span p s) return (cs,t) readRational :: String -> Rational -- NB: *does* handle a leading "-" readRational top_s = case top_s of '-' : xs -> - (read_me xs) xs -> read_me xs where read_me s = case (do { (x,"") <- readRational__ s ; return x }) of [x] -> x [] -> error ("readRational: no parse:" ++ top_s) _ -> error ("readRational: ambiguous parse:" ++ top_s)  simonmar committed Mar 18, 2005 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761  ----------------------------------------------------------------------------- -- Create a hierarchy of directories createDirectoryHierarchy :: FilePath -> IO () createDirectoryHierarchy dir = do b <- doesDirectoryExist dir when (not b) \$ do createDirectoryHierarchy (directoryOf dir) createDirectory dir ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists. -- doesDirNameExist :: FilePath -> IO Bool doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath) -- ----------------------------------------------------------------------------- -- Exception utils later = flip finally handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a handleDyn = flip catchDyn handle :: (Exception -> IO a) -> IO a -> IO a handle h f = f Exception.catch \e -> case e of ExitException _ -> throw e _ -> h e  simonmar committed Mar 24, 2005 762 763 764 765 766 767 768 769 770 771 -- -------------------------------------------------------------- -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) modificationTimeIfExists f = do (do t <- getModificationTime f; return (Just t)) IO.catch \e -> if isDoesNotExistError e then return Nothing else ioError e  simonmar committed Mar 18, 2005 772 773 774 -- -------------------------------------------------------------- -- Filename manipulation  simonmar committed May 17, 2005 775 776 777 778 -- Filenames are kept "normalised" inside GHC, using '/' as the path -- separator. On Windows these functions will also recognise '\\' as -- the path separator, but will generally construct paths using '/'.  simonmar committed Mar 18, 2005 779 780 781 782 783 type Suffix = String splitFilename :: String -> (String,Suffix) splitFilename f = splitLongestPrefix f (=='.')  simonmar committed May 17, 2005 784 785 786 787 788 basenameOf :: FilePath -> String basenameOf = fst . splitFilename suffixOf :: FilePath -> Suffix suffixOf = snd . splitFilename  simonmar committed Mar 18, 2005 789   simonmar committed May 16, 2005 790 791 792 793 joinFileExt :: String -> String -> FilePath joinFileExt path "" = path joinFileExt path ext = path ++ '.':ext  simonmar committed Mar 18, 2005 794 795 796 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext") splitFilenameDir :: String -> (String,String) splitFilenameDir str  simonmar committed May 16, 2005 797 798 799 800  = let (dir, rest) = splitLongestPrefix str isPathSeparator (dir', rest') | null rest = (".", dir) | otherwise = (dir, rest) in (dir', rest')  simonmar committed Mar 18, 2005 801 802 803 804  -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") splitFilename3 :: String -> (String,String,Suffix) splitFilename3 str  simonmar committed May 17, 2005 805 806 807 808 809 810 811 812 813  = let (dir, rest) = splitFilenameDir str (name, ext) = splitFilename rest in (dir, name, ext) joinFileName :: String -> String -> FilePath joinFileName "" fname = fname joinFileName "." fname = fname joinFileName dir "" = dir joinFileName dir fname = dir ++ '/':fname  simonmar committed Mar 18, 2005 814 815 816 817 818 819 820 821  -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string -- up (but not including) the last character for which 'pred' returned -- True, the second whatever comes after (but also not including the -- last character). -- -- If 'pred' returns False for all characters in the string, the original  simonmar committed May 17, 2005 822 -- string is returned in the first component (and the second one is just  simonmar committed Mar 18, 2005 823 824 -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)  simonpj committed May 23, 2005 825 826 827 828 829 830 splitLongestPrefix str pred | null r_pre = (str, []) | otherwise = (reverse (tail r_pre), reverse r_suf) -- 'tail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred (reverse str)  simonmar committed Mar 18, 2005 831 832  replaceFilenameSuffix :: FilePath -> Suffix -> FilePath  simonmar committed May 17, 2005 833 replaceFilenameSuffix file suf = basenameOf file joinFileExt suf  simonmar committed Mar 18, 2005 834 835 836 837 838 839 840 841 842 843 844 845  -- directoryOf strips the filename off the input string, returning -- the directory. directoryOf :: FilePath -> String directoryOf = fst . splitFilenameDir -- filenameOf strips the directory off the input string, returning -- the filename. filenameOf :: FilePath -> String filenameOf = snd . splitFilenameDir replaceFilenameDirectory :: FilePath -> String -> FilePath  simonmar committed May 17, 2005 846 replaceFilenameDirectory path dir = dir joinFileName filenameOf path  simonmar committed Mar 18, 2005 847 848 849 850 851 852 853 854 855 856 857  escapeSpaces :: String -> String escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" isPathSeparator :: Char -> Bool isPathSeparator ch = #ifdef mingw32_TARGET_OS ch == '/' || ch == '\\' #else ch == '/' #endif  simonmar committed Mar 21, 2005 858   simonmar committed Nov 04, 2005 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 -------------------------------------------------------------- -- * Search path -------------------------------------------------------------- -- | The function splits the given string to substrings -- using the 'searchPathSeparator'. parseSearchPath :: String -> [FilePath] parseSearchPath path = split path where split :: String -> [String] split s = case rest' of [] -> [chunk] _:rest -> chunk : split rest where chunk = case chunk' of #ifdef mingw32_HOST_OS ('\"':xs@(_:_)) | last xs == '\"' -> init xs #endif _ -> chunk' (chunk', rest') = break (==searchPathSeparator) s -- | A platform-specific character used to separate search path strings in -- environment variables. The separator is a colon (\":\") on Unix and Macintosh, -- and a semicolon (\";\") on the Windows operating system. searchPathSeparator :: Char #if mingw32_HOST_OS || mingw32_TARGET_OS searchPathSeparator = ';' #else searchPathSeparator = ':' #endif  simonmar committed Mar 21, 2005 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 ----------------------------------------------------------------------------- -- Convert filepath into platform / MSDOS form. -- We maintain path names in Unix form ('/'-separated) right until -- the last moment. On Windows we dos-ify them just before passing them -- to the Windows command. -- -- The alternative, of using '/' consistently on Unix and '\' on Windows, -- proved quite awkward. There were a lot more calls to platformPath, -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which -- interpreted a command line 'foo\baz' as 'foobaz'. normalisePath :: String -> String -- Just changes '\' to '/' pgmPath :: String -- Directory string in Unix format -> String -- Program name with no directory separators -- (e.g. copy /y) -> String -- Program invocation string in native format #if defined(mingw32_HOST_OS) --------------------- Windows version ------------------ normalisePath xs = subst '\\' '/' xs pgmPath dir pgm = platformPath dir ++ '\\' : pgm platformPath p = subst '/' '\\' p subst a b ls = map (\ x -> if x == a then b else x) ls #else --------------------- Non-Windows version -------------- normalisePath xs = xs pgmPath dir pgm = dir ++ '/' : pgm platformPath stuff = stuff -------------------------------------------------------- #endif  simonmar committed Aug 13, 2004 927 \end{code}