Util.lhs 27.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 % \begin{code}  batterseapower committed Aug 07, 2008 7 -- | Highly random utility functions  partain committed Jan 08, 1996 8 module Util (  batterseapower committed Aug 07, 2008 9  -- * Flags dependent on the compiler build  Ian Lynagh committed Jul 16, 2008 10  ghciSupported, debugIsOn, ghciTablesNextToCode, picIsOn,  Ian Lynagh committed Jun 14, 2008 11  isWindowsHost, isWindowsTarget, isDarwinTarget,  sof committed May 18, 1997 12   batterseapower committed Aug 07, 2008 13  -- * General list processing  Ian Lynagh committed Jan 13, 2008 14  zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,  simonpj committed Mar 23, 2000 15  zipLazy, stretchZipWith,  batterseapower committed Aug 07, 2008 16 17 18  unzipWith,  Ian Lynagh committed Jan 13, 2008 19 20 21  mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, nOfThem, filterOut, partitionWith, splitEithers,  batterseapower committed Aug 07, 2008 22 23  foldl1', foldl2, count, all2,  24   Ian Lynagh committed Jan 13, 2008 25 26 27 28 29 30 31  lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, equalLength, compareLength, isSingleton, only, singleton, notNull, snocView, isIn, isn'tIn,  32   batterseapower committed Aug 07, 2008 33 34 35 36  -- * List operations controlled by another list takeList, dropList, splitAtList, split, -- * For loop  Ian Lynagh committed Jan 13, 2008 37  nTimes,  sof committed Apr 05, 2002 38   batterseapower committed Aug 07, 2008 39  -- * Sorting  Ian Lynagh committed Jan 13, 2008 40  sortLe, sortWith, on,  partain committed Jan 08, 1996 41   batterseapower committed Aug 07, 2008 42  -- * Comparisons  Ian Lynagh committed Jan 13, 2008 43 44 45  isEqual, eqListBy, thenCmp, cmpList, maybePrefixMatch, removeSpaces,  partain committed Jan 08, 1996 46   batterseapower committed Aug 07, 2008 47 48  -- * Transitive closures transitiveClosure,  simonm committed Mar 04, 1999 49   batterseapower committed Aug 07, 2008 50 51  -- * Strictness seqList,  simonmar committed Jun 03, 1999 52   batterseapower committed Aug 07, 2008 53  -- * Module names  Ian Lynagh committed Jan 13, 2008 54  looksLikeModuleName,  simonmar committed Oct 15, 2002 55   batterseapower committed Aug 07, 2008 56  -- * Argument processing  Ian Lynagh committed Jan 19, 2008 57  getCmd, toCmdArgs, toArgs,  simonmar committed Aug 13, 2004 58   batterseapower committed Aug 07, 2008 59  -- * Floating point  Ian Lynagh committed Jan 13, 2008 60  readRational,  simonmar committed Mar 18, 2005 61   batterseapower committed Aug 07, 2008 62  -- * IO-ish utilities  Ian Lynagh committed Jan 13, 2008 63 64 65  createDirectoryHierarchy, doesDirNameExist, modificationTimeIfExists,  simonmar committed Mar 18, 2005 66   batterseapower committed Aug 07, 2008 67 68 69  global, consIORef, -- * Filenames and paths  Ian Lynagh committed Jan 13, 2008 70 71 72 73  Suffix, splitLongestPrefix, escapeSpaces, parseSearchPath,  Ian Lynagh committed Jan 16, 2008 74  Direction(..), reslash,  partain committed Jan 08, 1996 75 76  ) where  simonm committed Jan 08, 1998 77 78 #include "HsVersions.h"  Simon Marlow committed Sep 12, 2007 79 import Panic  Michael D. Adams committed Jul 13, 2007 80   Ian Lynagh committed Jan 13, 2008 81 82 83 import Data.IORef ( IORef, newIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef ( readIORef, writeIORef )  Simon Marlow committed Sep 12, 2007 84 import Data.List hiding (group)  simonmar committed Aug 29, 2002 85   Michael D. Adams committed Jul 13, 2007 86 import qualified Data.List as List ( elem )  Simon Marlow committed Sep 12, 2007 87 #ifdef DEBUG  Michael D. Adams committed Jul 13, 2007 88 import qualified Data.List as List ( notElem )  mainland@eecs.harvard.edu committed Jan 14, 2008 89 import FastTypes  sewardj committed Oct 27, 2000 90 #endif  sof committed May 28, 2001 91   Ian Lynagh committed Jan 13, 2008 92 import Control.Monad ( unless )  Ian Lynagh committed Jun 20, 2008 93 import System.IO.Error as IO ( catch, isDoesNotExistError )  Ian Lynagh committed Jan 13, 2008 94 import System.Directory ( doesDirectoryExist, createDirectory,  Simon Marlow committed Oct 11, 2006 95  getModificationTime )  Simon Marlow committed Aug 18, 2008 96 import System.FilePath  Ian Lynagh committed Jan 13, 2008 97 98 99 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) import Data.Ratio ( (%) ) import System.Time ( ClockTime )  simonmar committed Oct 15, 2002 100   partain committed May 16, 1996 101 infixr 9 thenCmp  partain committed Jan 08, 1996 102 103 \end{code}  Ian Lynagh committed Mar 29, 2008 104 105 %************************************************************************ %* *  Ian Lynagh committed Jul 16, 2008 106 \subsection{Is DEBUG on, are we on Windows, etc?}  Ian Lynagh committed Mar 29, 2008 107 108 109 %* * %************************************************************************  simonpj@microsoft.com committed Sep 15, 2008 110 111 112 113 114 115 116 117 118 These booleans are global constants, set by CPP flags. They allow us to recompile a single module (this one) to change whether or not debug output appears. They sometimes let us avoid even running CPP elsewhere. It's important that the flags are literal constants (True/False). Then, with -0, tests of the flags in other modules will simplify to the correct branch of the conditional, thereby dropping debug code altogether when the flags are off.  Ian Lynagh committed Mar 29, 2008 119 \begin{code}  Ian Lynagh committed Jul 16, 2008 120 121 122 123 124 125 126 ghciSupported :: Bool #ifdef GHCI ghciSupported = True #else ghciSupported = False #endif  Ian Lynagh committed Mar 29, 2008 127 128 129 130 131 132 debugIsOn :: Bool #ifdef DEBUG debugIsOn = True #else debugIsOn = False #endif  Ian Lynagh committed Jun 12, 2008 133   Ian Lynagh committed Jun 14, 2008 134 135 136 137 138 139 140 ghciTablesNextToCode :: Bool #ifdef GHCI_TABLES_NEXT_TO_CODE ghciTablesNextToCode = True #else ghciTablesNextToCode = False #endif  Ian Lynagh committed Jun 14, 2008 141 142 143 144 145 146 147 picIsOn :: Bool #ifdef __PIC__ picIsOn = True #else picIsOn = False #endif  Ian Lynagh committed Jun 12, 2008 148 149 150 151 152 153 isWindowsHost :: Bool #ifdef mingw32_HOST_OS isWindowsHost = True #else isWindowsHost = False #endif  Ian Lynagh committed Jun 14, 2008 154 155 156 157 158 159 160 161 162 163 164 165 166 167  isWindowsTarget :: Bool #ifdef mingw32_TARGET_OS isWindowsTarget = True #else isWindowsTarget = False #endif isDarwinTarget :: Bool #ifdef darwin_TARGET_OS isDarwinTarget = True #else isDarwinTarget = False #endif  Ian Lynagh committed Mar 29, 2008 168 169 \end{code}  simonpj committed Mar 23, 2000 170 %************************************************************************  Ian Lynagh committed Jan 13, 2008 171 %* *  simonpj committed Mar 23, 2000 172 \subsection{A for loop}  Ian Lynagh committed Jan 13, 2008 173 %* *  simonpj committed Mar 23, 2000 174 175 176 %************************************************************************ \begin{code}  batterseapower committed Aug 07, 2008 177 -- | Compose a function with itself n times. (nth rather than twice)  simonpj committed Mar 23, 2000 178 179 180 181 182 183 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 184 %************************************************************************  Ian Lynagh committed Jan 13, 2008 185 %* *  partain committed Jan 08, 1996 186 \subsection[Utils-lists]{General list processing}  Ian Lynagh committed Jan 13, 2008 187 %* *  partain committed Jan 08, 1996 188 189 %************************************************************************  simonmar committed Aug 13, 2004 190 191 \begin{code} filterOut :: (a->Bool) -> [a] -> [a]  batterseapower committed Aug 07, 2008 192 -- ^ Like filter, only it reverses the sense of the test  Ian Lynagh committed Jan 13, 2008 193 filterOut _ [] = []  simonmar committed Aug 13, 2004 194 filterOut p (x:xs) | p x = filterOut p xs  Ian Lynagh committed Jan 13, 2008 195  | otherwise = x : filterOut p xs  simonpj@microsoft.com committed Nov 10, 2006 196 197  partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])  batterseapower committed Aug 07, 2008 198 -- ^ Uses a function to determine which of two output lists an input element should join  Ian Lynagh committed Jan 13, 2008 199 partitionWith _ [] = ([],[])  simonpj@microsoft.com committed Nov 10, 2006 200 partitionWith f (x:xs) = case f x of  Ian Lynagh committed Jan 13, 2008 201 202 203  Left b -> (b:bs, cs) Right c -> (bs, c:cs) where (bs,cs) = partitionWith f xs  simonpj@microsoft.com committed Nov 10, 2006 204   simonpj@microsoft.com committed Jan 02, 2007 205 splitEithers :: [Either a b] -> ([a], [b])  batterseapower committed Aug 07, 2008 206 -- ^ Teases a list of 'Either's apart into two lists  simonpj@microsoft.com committed Jan 02, 2007 207 208 splitEithers [] = ([],[]) splitEithers (e : es) = case e of  Ian Lynagh committed Jan 13, 2008 209 210 211  Left x -> (x:xs, ys) Right y -> (xs, y:ys) where (xs,ys) = splitEithers es  simonmar committed Aug 13, 2004 212 213 \end{code}  partain committed Mar 19, 1996 214 215 216 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 217 218  \begin{code}  Ian Lynagh committed Jan 13, 2008 219 220 221 222 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 223 224  #ifndef DEBUG  partain committed May 16, 1996 225 226 227 228 zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = zipWith4  partain committed Jan 08, 1996 229 #else  simonpj@microsoft.com committed Jan 17, 2008 230 zipEqual _ [] [] = []  partain committed May 16, 1996 231 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs  simonpj@microsoft.com committed Jan 17, 2008 232 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)  partain committed May 16, 1996 233 234  zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs  simonpj@microsoft.com committed Jan 17, 2008 235 zipWithEqual _ _ [] [] = []  Ian Lynagh committed Jan 13, 2008 236 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)  partain committed May 16, 1996 237 238  zipWith3Equal msg z (a:as) (b:bs) (c:cs)  Ian Lynagh committed Jan 13, 2008 239  = z a b c : zipWith3Equal msg z as bs cs  simonpj@microsoft.com committed Jan 17, 2008 240 zipWith3Equal _ _ [] [] [] = []  Ian Lynagh committed Jan 13, 2008 241 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)  partain committed May 16, 1996 242 243  zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)  Ian Lynagh committed Jan 13, 2008 244  = z a b c d : zipWith4Equal msg z as bs cs ds  simonpj@microsoft.com committed Jan 17, 2008 245 zipWith4Equal _ _ [] [] [] [] = []  Ian Lynagh committed Jan 13, 2008 246 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)  partain committed Jan 08, 1996 247 248 249 #endif \end{code}  partain committed Mar 19, 1996 250 \begin{code}  batterseapower committed Aug 07, 2008 251 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)  partain committed Mar 19, 1996 252 zipLazy :: [a] -> [b] -> [(a,b)]  Ian Lynagh committed Jan 13, 2008 253 zipLazy [] _ = []  Ian Lynagh committed May 13, 2008 254 255 256 257 258 259 -- We want to write this, but with GHC 6.4 we get a warning, so it -- doesn't validate: -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys -- so we write this instead: zipLazy (x:xs) zs = let y : ys = zs in (x,y) : zipLazy xs ys  partain committed Mar 19, 1996 260 261 \end{code}  simonm committed Dec 02, 1998 262 263  \begin{code}  simonpj committed Mar 23, 2000 264 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]  batterseapower committed Aug 07, 2008 265 266 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in -- the places where @p@ returns @True@  simonpj committed Mar 23, 2000 267   Ian Lynagh committed Jan 13, 2008 268 stretchZipWith _ _ _ [] _ = []  simonpj committed Mar 23, 2000 269 270 271 stretchZipWith p z f (x:xs) ys | p x = f x z : stretchZipWith p z f xs ys | otherwise = case ys of  Ian Lynagh committed Jan 13, 2008 272 273  [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys  simonm committed Dec 02, 1998 274 275 276 \end{code}  partain committed Apr 30, 1996 277 \begin{code}  simonpj committed Apr 04, 2005 278 279 280 281 282 283 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 284 285 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])  Ian Lynagh committed Jan 13, 2008 286 mapAndUnzip _ [] = ([], [])  partain committed Apr 30, 1996 287 mapAndUnzip f (x:xs)  Ian Lynagh committed Jan 13, 2008 288 289  = let (r1, r2) = f x (rs1, rs2) = mapAndUnzip f xs  partain committed Apr 30, 1996 290 291  in (r1:rs1, r2:rs2)  partain committed May 17, 1996 292 293 294  mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])  Ian Lynagh committed Jan 13, 2008 295 mapAndUnzip3 _ [] = ([], [], [])  partain committed May 17, 1996 296 mapAndUnzip3 f (x:xs)  Ian Lynagh committed Jan 13, 2008 297 298  = let (r1, r2, r3) = f x (rs1, rs2, rs3) = mapAndUnzip3 f xs  partain committed May 17, 1996 299 300  in (r1:rs1, r2:rs2, r3:rs3)  partain committed Apr 30, 1996 301 302 \end{code}  partain committed Jan 08, 1996 303 304 \begin{code} nOfThem :: Int -> a -> [a]  sof committed Mar 01, 1999 305 nOfThem n thing = replicate n thing  partain committed Jan 08, 1996 306   batterseapower committed Aug 07, 2008 307 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:  sof committed Oct 25, 2001 308 --  batterseapower committed Aug 07, 2008 309 -- @  sof committed Oct 25, 2001 310 311 312 313 -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred n -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls)  batterseapower committed Aug 07, 2008 314 -- @  sof committed Oct 25, 2001 315 316 317 318 319 atLength :: ([a] -> b) -> (Int -> b) -> [a] -> Int -> b  Ian Lynagh committed Jan 13, 2008 320 321 atLength atLenPred atEndPred ls n | n < 0 = atEndPred n  sof committed Oct 25, 2001 322 323 324 325 326 327  | otherwise = go n ls where go n [] = atEndPred n go 0 ls = atLenPred ls go n (_:xs) = go (n-1) xs  batterseapower committed Aug 07, 2008 328 329 -- Some special cases of atLength:  partain committed Jan 08, 1996 330 lengthExceeds :: [a] -> Int -> Bool  batterseapower committed Aug 07, 2008 331 -- ^ > (lengthExceeds xs n) = (length xs > n)  sof committed Apr 05, 2002 332 lengthExceeds = atLength notNull (const False)  sof committed Oct 25, 2001 333 334  lengthAtLeast :: [a] -> Int -> Bool  sof committed Apr 05, 2002 335 lengthAtLeast = atLength notNull (== 0)  sof committed Oct 25, 2001 336 337 338 339  lengthIs :: [a] -> Int -> Bool lengthIs = atLength null (==0)  Ian Lynagh committed Jan 13, 2008 340 341 listLengthCmp :: [a] -> Int -> Ordering listLengthCmp = atLength atLen atEnd  sof committed Oct 25, 2001 342 343 344 345 346 347 348 349  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 350   simonpj@microsoft.com committed Aug 15, 2006 351 equalLength :: [a] -> [b] -> Bool  Ian Lynagh committed Jan 13, 2008 352 equalLength [] [] = True  simonpj@microsoft.com committed Aug 15, 2006 353 equalLength (_:xs) (_:ys) = equalLength xs ys  Ian Lynagh committed Jan 13, 2008 354 equalLength _ _ = False  simonpj@microsoft.com committed Aug 15, 2006 355 356  compareLength :: [a] -> [b] -> Ordering  Ian Lynagh committed Jan 13, 2008 357 compareLength [] [] = EQ  simonpj@microsoft.com committed Aug 15, 2006 358 compareLength (_:xs) (_:ys) = compareLength xs ys  Ian Lynagh committed Jan 13, 2008 359 360 compareLength [] _ = LT compareLength _ [] = GT  simonpj@microsoft.com committed Aug 15, 2006 361 362  ----------------------------  simonpj committed Jul 19, 2005 363 364 365 singleton :: a -> [a] singleton x = [x]  partain committed Jan 08, 1996 366 isSingleton :: [a] -> Bool  Ian Lynagh committed Jan 13, 2008 367 368 isSingleton [_] = True isSingleton _ = False  simonm committed Apr 27, 1999 369   sof committed Apr 05, 2002 370 371 372 373 notNull :: [a] -> Bool notNull [] = False notNull _ = True  simonm committed Apr 27, 1999 374 375 376 377 378 379 only :: [a] -> a #ifdef DEBUG only [a] = a #else only (a:_) = a #endif  Ian Lynagh committed Jan 13, 2008 380 only _ = panic "Util: only"  partain committed Jan 08, 1996 381 382 383 \end{code} Debugging/specialising versions of \tr{elem} and \tr{notElem}  simonm committed Jan 08, 1998 384   partain committed Jan 08, 1996 385 \begin{code}  Ian Lynagh committed Jan 13, 2008 386 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool  partain committed Jan 08, 1996 387 388  # ifndef DEBUG  Ian Lynagh committed Jan 13, 2008 389 390 isIn _msg x ys = elem__ x ys isn'tIn _msg x ys = notElem__ x ys  partain committed Jan 08, 1996 391 392  --these are here to be SPECIALIZEd (automagically)  Ian Lynagh committed Jan 13, 2008 393 394 395 elem__ :: Eq a => a -> [a] -> Bool elem__ _ [] = False elem__ x (y:ys) = x == y || elem__ x ys  partain committed Jan 08, 1996 396   Ian Lynagh committed Jan 13, 2008 397 398 399 notElem__ :: Eq a => a -> [a] -> Bool notElem__ _ [] = True notElem__ x (y:ys) = x /= y && notElem__ x ys  partain committed Jan 08, 1996 400   ross committed Jun 08, 2003 401 # else /* DEBUG */  partain committed Jan 08, 1996 402 isIn msg x ys  Isaac Dupree committed Jan 17, 2008 403  = elem (_ILIT(0)) x ys  partain committed Jan 08, 1996 404  where  simonpj@microsoft.com committed Jan 17, 2008 405  elem _ _ [] = False  partain committed Jan 08, 1996 406  elem i x (y:ys)  Isaac Dupree committed Jan 17, 2008 407 408 409  | 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 410 411  isn'tIn msg x ys  Isaac Dupree committed Jan 17, 2008 412  = notElem (_ILIT(0)) x ys  partain committed Jan 08, 1996 413  where  simonpj@microsoft.com committed Jan 17, 2008 414  notElem _ _ [] = True  partain committed Jan 08, 1996 415  notElem i x (y:ys)  Isaac Dupree committed Jan 17, 2008 416 417  | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg) (x List.notElem (y:ys))  simonpj committed Jan 04, 2002 418  | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys  ross committed Jun 08, 2003 419 # endif /* DEBUG */  partain committed Jan 08, 1996 420 421 422 \end{code} %************************************************************************  Ian Lynagh committed Jan 13, 2008 423 %* *  partain committed Jan 08, 1996 424 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}  Ian Lynagh committed Jan 13, 2008 425 %* *  partain committed Jan 08, 1996 426 427 428 429 430 431 432 433 %************************************************************************ \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 434 Here is a piece of Haskell code that I'm rather fond of. See it as an  partain committed Jan 11, 1996 435 436 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 437 believe the lazy version is due to me [surprisingly complicated].  partain committed Jan 11, 1996 438 439 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 440 441 442 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 443 444 445 446 447 448  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 449  4) a super-optimized-quick-sort of Lennart's  partain committed Jan 08, 1996 450 451 452 453  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 454 merge sort is marginally beaten by Lennart's soqs. The space  partain committed Jan 11, 1996 455 consumption of merge sort is a bit worse than Lennart's quick sort  partain committed Jan 08, 1996 456 457 458 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 459 have fun  partain committed Jan 08, 1996 460 461 462 463 464 Carsten \end{display} \begin{code} group :: (a -> a -> Bool) -> [a] -> [[a]]  Ian Lynagh committed Jan 13, 2008 465 -- Given a <= function, group finds maximal contiguous up-runs  simonpj committed Oct 01, 2004 466 467 468 469 470 471 -- 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 472   Ian Lynagh committed Jan 13, 2008 473 group _ [] = []  partain committed Mar 19, 1996 474 475 476 group p (x:xs) = group' xs x x (x :) where group' [] _ _ s = [s []]  Ian Lynagh committed Jan 13, 2008 477 478 479 480 481 482  group' (x:xs) x_min x_max s | x_max p x = group' xs x_min x (s . (x :)) | not (x_min p x) = group' xs x x_max ((x :) . s) | otherwise = s [] : group' xs x x (x :) -- NB: the 'not' is essential for stablity -- x p x_min would reverse equal elements  partain committed Jan 08, 1996 483 484  generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]  Ian Lynagh committed Jan 13, 2008 485 486 487 488 generalMerge _ xs [] = xs generalMerge _ [] ys = ys generalMerge p (x:xs) (y:ys) | x p y = x : generalMerge p xs (y:ys) | otherwise = y : generalMerge p (x:xs) ys  partain committed Jan 08, 1996 489 490 491 492  -- gamma is now called balancedFold balancedFold :: (a -> a -> a) -> [a] -> a  Ian Lynagh committed Jan 13, 2008 493 494 balancedFold _ [] = error "can't reduce an empty list using balancedFold" balancedFold _ [x] = x  partain committed Jan 08, 1996 495 496 497 498 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  Ian Lynagh committed Jan 13, 2008 499 balancedFold' _ xs = xs  partain committed Jan 08, 1996 500   Ian Lynagh committed Jan 13, 2008 501 502 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a] generalNaturalMergeSort _ [] = []  partain committed Jan 11, 1996 503 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs  partain committed Jan 08, 1996 504   simonmar committed Aug 29, 2002 505 #if NOT_USED  simonpj committed Oct 09, 2003 506 507 508 generalMergeSort p [] = [] generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs  partain committed Jan 08, 1996 509 510 511 512 513 514 mergeSort, naturalMergeSort :: Ord a => [a] -> [a] mergeSort = generalMergeSort (<=) naturalMergeSort = generalNaturalMergeSort (<=) mergeSortLe le = generalMergeSort le  simonmar committed Aug 29, 2002 515 516 #endif  simonpj committed Aug 17, 2004 517 518 sortLe :: (a->a->Bool) -> [a] -> [a] sortLe le = generalNaturalMergeSort le  simonpj committed Dec 22, 2004 519 520 521 522  sortWith :: Ord b => (a->b) -> [a] -> [a] sortWith get_key xs = sortLe le xs where  Ian Lynagh committed Jan 13, 2008 523  x le y = get_key x < get_key y  mnislaih committed Aug 14, 2007 524 525 526 527  on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering on cmp sel = \x y -> sel x cmp sel y  partain committed Jan 08, 1996 528 529 530 \end{code} %************************************************************************  Ian Lynagh committed Jan 13, 2008 531 %* *  partain committed Jan 08, 1996 532 \subsection[Utils-transitive-closure]{Transitive closure}  Ian Lynagh committed Jan 13, 2008 533 %* *  partain committed Jan 08, 1996 534 535 536 537 538 %************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. \begin{code}  Ian Lynagh committed Jan 13, 2008 539 540 541 542 transitiveClosure :: (a -> [a]) -- Successor function -> (a -> a -> Bool) -- Equality predicate -> [a] -> [a] -- The transitive closure  partain committed Jan 08, 1996 543 544  transitiveClosure succ eq xs  partain committed Jun 05, 1996 545  = go [] xs  partain committed Jan 08, 1996 546  where  Ian Lynagh committed Jan 13, 2008 547  go done [] = done  partain committed Jun 05, 1996 548  go done (x:xs) | x is_in done = go done xs  Ian Lynagh committed Jan 13, 2008 549  | otherwise = go (x:done) (succ x ++ xs)  partain committed Jan 08, 1996 550   Ian Lynagh committed Jan 13, 2008 551  _ is_in [] = False  partain committed Jan 08, 1996 552  x is_in (y:ys) | eq x y = True  Ian Lynagh committed Jan 13, 2008 553  | otherwise = x is_in ys  partain committed Jan 08, 1996 554 555 556 \end{code} %************************************************************************  Ian Lynagh committed Jan 13, 2008 557 %* *  partain committed Jan 08, 1996 558 \subsection[Utils-accum]{Accumulating}  Ian Lynagh committed Jan 13, 2008 559 %* *  partain committed Jan 08, 1996 560 561 %************************************************************************  simonpj committed May 18, 1999 562 563 564 565 A combination of foldl with zip. It works with equal length lists. \begin{code} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc  Ian Lynagh committed Jan 13, 2008 566 foldl2 _ z [] [] = z  simonpj committed May 18, 1999 567 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs  Ian Lynagh committed Jan 13, 2008 568 foldl2 _ _ _ _ = panic "Util: foldl2"  simonpj committed Nov 16, 2005 569 570  all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool  Ian Lynagh committed Jan 13, 2008 571 -- True if the lists are the same length, and  simonpj committed Nov 16, 2005 572 -- all corresponding elements satisfy the predicate  Ian Lynagh committed Jan 13, 2008 573 all2 _ [] [] = True  simonpj committed Nov 16, 2005 574 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys  Ian Lynagh committed Jan 13, 2008 575 all2 _ _ _ = False  simonpj committed May 18, 1999 576 577 578 579 580 581 \end{code} Count the number of times a predicate is true \begin{code} count :: (a -> Bool) -> [a] -> Int  Ian Lynagh committed Jan 13, 2008 582 count _ [] = 0  simonpj committed May 18, 1999 583 count p (x:xs) | p x = 1 + count p xs  Ian Lynagh committed Jan 13, 2008 584  | otherwise = count p xs  simonpj committed May 18, 1999 585 586 \end{code}  sof committed Oct 25, 2001 587 588 589 590 591 592 @splitAt@, @take@, and @drop@ but with length of another list giving the break-off point: \begin{code} takeList :: [b] -> [a] -> [a] takeList [] _ = []  Ian Lynagh committed Jan 13, 2008 593 takeList (_:xs) ls =  sof committed Oct 25, 2001 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610  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 611 snocView :: [a] -> Maybe ([a],a)  Ian Lynagh committed Jan 13, 2008 612  -- Split off the last element  simonpj@microsoft.com committed Sep 23, 2006 613 614 snocView [] = Nothing snocView xs = go [] xs  Ian Lynagh committed Jan 13, 2008 615 616 617 618 619  where -- Invariant: second arg is non-empty go acc [x] = Just (reverse acc, x) go acc (x:xs) = go (x:acc) xs go _ [] = panic "Util: snocView"  simonpj@microsoft.com committed Sep 23, 2006 620   simonmar committed Mar 18, 2005 621 622 split :: Char -> String -> [String] split c s = case rest of  Ian Lynagh committed Jan 13, 2008 623 624  [] -> [chunk] _:rest -> chunk : split c rest  simonmar committed Mar 18, 2005 625  where (chunk, rest) = break (==c) s  sof committed Oct 25, 2001 626 627 \end{code}  simonpj committed May 18, 1999 628   partain committed Jan 08, 1996 629 %************************************************************************  Ian Lynagh committed Jan 13, 2008 630 %* *  partain committed Jan 08, 1996 631 \subsection[Utils-comparison]{Comparisons}  Ian Lynagh committed Jan 13, 2008 632 %* *  partain committed Jan 08, 1996 633 634 %************************************************************************  partain committed Mar 19, 1996 635 \begin{code}  simonpj committed Dec 20, 2004 636 637 638 639 640 641 642 643 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 #-}  Ian Lynagh committed Jan 13, 2008 644 645 thenCmp EQ ordering = ordering thenCmp ordering _ = ordering  simonpj committed Dec 20, 2004 646   simonpj committed Jul 19, 2001 647 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool  Ian Lynagh committed Jan 13, 2008 648 eqListBy _ [] [] = True  simonpj committed Jul 19, 2001 649 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys  Ian Lynagh committed Jan 13, 2008 650 eqListBy _ _ _ = False  simonpj committed Jul 19, 2001 651   simonm committed Jan 08, 1998 652 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering  partain committed Mar 19, 1996 653 654  -- cmpList' uses a user-specified comparer  Ian Lynagh committed Jan 13, 2008 655 656 657 cmpList _ [] [] = EQ cmpList _ [] _ = LT cmpList _ _ [] = GT  partain committed Mar 19, 1996 658 cmpList cmp (a:as) (b:bs)  simonm committed Jan 08, 1998 659  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }  partain committed Mar 19, 1996 660 661 \end{code}  partain committed Jan 08, 1996 662 \begin{code}  Ian Lynagh committed Aug 04, 2007 663 664 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8. -- This definition can be removed once we require at least 6.8 to build.  simonmar committed Aug 20, 2003 665 666 667 668 669 670 671 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 672 673 removeSpaces :: String -> String removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace  partain committed Jan 08, 1996 674 675 676 \end{code} %************************************************************************  Ian Lynagh committed Jan 13, 2008 677 %* *  partain committed Jan 08, 1996 678 \subsection[Utils-pairs]{Pairs}  Ian Lynagh committed Jan 13, 2008 679 %* *  partain committed Jan 08, 1996 680 681 682 683 684 685 686 %************************************************************************ \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 687 688 689 690 \begin{code} seqList :: [a] -> b -> b seqList [] b = b seqList (x:xs) b = x seq seqList xs b  simonmar committed Jun 01, 1999 691 \end{code}  simonmar committed Oct 11, 2000 692 693 694 695 696 697 698  Global variables: \begin{code} global :: a -> IORef a global a = unsafePerformIO (newIORef a) \end{code}  simonmar committed Oct 15, 2002 699   simonmar committed Mar 18, 2005 700 701 702 703 704 705 706 \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 707 708 709 Module names: \begin{code}  Ian Lynagh committed Jul 02, 2007 710 looksLikeModuleName :: String -> Bool  simonmar committed Oct 15, 2002 711 looksLikeModuleName [] = False  simonmar committed Jan 09, 2003 712 713 looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True  Ian Lynagh committed Jan 13, 2008 714 715  go ('.':cs) = looksLikeModuleName cs go (c:cs) = (isAlphaNum c || c == '_') && go cs  simonmar committed Oct 15, 2002 716 \end{code}  sof committed Feb 13, 2003 717   rjmccall@gmail.com committed Sep 17, 2006 718 Akin to @Prelude.words@, but acts like the Bourne shell, treating  Ian Lynagh committed Jan 19, 2008 719 720 quoted strings as Haskell Strings, and also parses Haskell [String] syntax.  sof committed Feb 13, 2003 721 722  \begin{code}  Ian Lynagh committed Jan 19, 2008 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 getCmd :: String -> Either String -- Error (String, String) -- (Cmd, Rest) getCmd s = case break isSpace $dropWhile isSpace s of ([], _) -> Left ("Couldn't find command in " ++ show s) res -> Right res toCmdArgs :: String -> Either String -- Error (String, [String]) -- (Cmd, Args) toCmdArgs s = case getCmd s of Left err -> Left err Right (cmd, s') -> case toArgs s' of Left err -> Left err Right args -> Right (cmd, args) toArgs :: String -> Either String -- Error [String] -- Args toArgs str = case dropWhile isSpace str of s@('[':_) -> case reads s of [(args, spaces)] | all isSpace spaces -> Right args _ -> Left ("Couldn't read " ++ show str ++ "as [String]") s -> toArgs' s  sof committed Feb 13, 2003 748  where  Ian Lynagh committed Jan 19, 2008 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763  toArgs' s = case dropWhile isSpace s of [] -> Right [] ('"' : _) -> case reads s of [(arg, rest)] -- rest must either be [] or start with a space | all isSpace (take 1 rest) -> case toArgs' rest of Left err -> Left err Right args -> Right (arg : args) _ -> Left ("Couldn't read " ++ show s ++ "as String") s' -> case break isSpace s' of (arg, s'') -> case toArgs' s'' of Left err -> Left err Right args -> Right (arg : args)  sof committed Feb 13, 2003 764 \end{code}  simonmar committed Aug 13, 2004 765 766 767 768 769 770  -- ----------------------------------------------------------------------------- -- Floats \begin{code} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"  Ian Lynagh committed Jan 13, 2008 771 readRational__ r = do  simonmar committed Aug 13, 2004 772 773 774 775 776  (n,d,s) <- readFix r (k,t) <- readExp s return ((n%1)*10^^(k-d), t) where readFix r = do  Ian Lynagh committed Jan 13, 2008 777 778 779  (ds,s) <- lexDecDigits r (ds',t) <- lexDotDigits s return (read (ds++ds'), length ds', t)  simonmar committed Aug 13, 2004 780 781  readExp (e:s) | e elem "eE" = readExp' s  Ian Lynagh committed Jan 13, 2008 782  readExp s = return (0,s)  simonmar committed Aug 13, 2004 783 784  readExp' ('+':s) = readDec s  Ian Lynagh committed Jan 13, 2008 785 786 787  readExp' ('-':s) = do (k,t) <- readDec s return (-k,t) readExp' s = readDec s  simonmar committed Aug 13, 2004 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809  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  Ian Lynagh committed Jan 13, 2008 810 811 812  [x] -> x [] -> error ("readRational: no parse:" ++ top_s) _ -> error ("readRational: ambiguous parse:" ++ top_s)  simonmar committed Mar 18, 2005 813 814 815 816 817 818  ----------------------------------------------------------------------------- -- Create a hierarchy of directories createDirectoryHierarchy :: FilePath -> IO ()  Ian Lynagh committed Jan 12, 2008 819 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack  simonmar committed Mar 18, 2005 820 821 createDirectoryHierarchy dir = do b <- doesDirectoryExist dir  Ian Lynagh committed Jan 13, 2008 822 823  unless b$ do createDirectoryHierarchy (takeDirectory dir) createDirectory dir  simonmar committed Mar 18, 2005 824 825 826  ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists.  Ian Lynagh committed Jan 13, 2008 827 --  simonmar committed Mar 18, 2005 828 doesDirNameExist :: FilePath -> IO Bool  Ian Lynagh committed Jan 12, 2008 829 doesDirNameExist fpath = case takeDirectory fpath of  Ian Lynagh committed Jan 13, 2008 830 831  "" -> return True -- XXX Hack _ -> doesDirectoryExist (takeDirectory fpath)  simonmar committed Mar 18, 2005 832   simonmar committed Mar 24, 2005 833 834 835 836 837 838 -- -------------------------------------------------------------- -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) modificationTimeIfExists f = do (do t <- getModificationTime f; return (Just t))  Ian Lynagh committed Jan 13, 2008 839 840 841  IO.catch \e -> if isDoesNotExistError e then return Nothing else ioError e  simonmar committed Mar 24, 2005 842   simonmar committed Mar 18, 2005 843 844 845 846 847 848 849 -- 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 850 -- string is returned in the first component (and the second one is just  simonmar committed Mar 18, 2005 851 852 -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)  simonpj committed May 23, 2005 853 854 855 splitLongestPrefix str pred | null r_pre = (str, []) | otherwise = (reverse (tail r_pre), reverse r_suf)  Ian Lynagh committed Jan 13, 2008 856 857  -- 'tail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred (reverse str)  simonmar committed Mar 18, 2005 858 859 860 861  escapeSpaces :: String -> String escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""  Ian Lynagh committed Jan 12, 2008 862 type Suffix = String  simonmar committed Mar 21, 2005 863   simonmar committed Nov 04, 2005 864 865 866 867 868 869 870 871 872 873 874 875 -------------------------------------------------------------- -- * 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  Ian Lynagh committed Jan 13, 2008 876  [] -> [chunk]  simonmar committed Nov 04, 2005 877 878  _:rest -> chunk : split rest where  Ian Lynagh committed Jan 13, 2008 879  chunk =  simonmar committed Nov 04, 2005 880 881 882 883 884 885  case chunk' of #ifdef mingw32_HOST_OS ('\"':xs@(_:_)) | last xs == '\"' -> init xs #endif _ -> chunk'  Simon Marlow committed Aug 18, 2008 886  (chunk', rest') = break isSearchPathSeparator s  Ian Lynagh committed Jan 16, 2008 887 888 889 890 891 892 893 894 895 896 897 898  data Direction = Forwards | Backwards reslash :: Direction -> FilePath -> FilePath reslash d = f where f ('/' : xs) = slash : f xs f ('\\' : xs) = slash : f xs f (x : xs) = x : f xs f "" = "" slash = case d of Forwards -> '/' Backwards -> '\\'  simonmar committed Aug 13, 2004 899 \end{code}  Ian Lynagh committed Jan 16, 2008 900