compiler/utils/Util.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The University of Glasgow 1992-2002
   4 %
   5
   6 \begin{code}
   7 -- | Highly random utility functions
   8 module Util (
   9         -- * Flags dependent on the compiler build
  10         ghciSupported, debugIsOn, ghciTablesNextToCode, isDynamicGhcLib,
  11         isWindowsHost, isWindowsTarget, isDarwinTarget,
  12
  13         -- * General list processing
  14         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
  15         zipLazy, stretchZipWith,
  16
  17         unzipWith,
  18
  19         mapFst, mapSnd,
  20         mapAndUnzip, mapAndUnzip3,
  21         nOfThem, filterOut, partitionWith, splitEithers,
  22
  23         foldl1', foldl2, count, all2,
  24
  25         lengthExceeds, lengthIs, lengthAtLeast,
  26         listLengthCmp, atLength, equalLength, compareLength,
  27
  28         isSingleton, only, singleton,
  29         notNull, snocView,
  30
  31         isIn, isn'tIn,
  32
  33         -- * Tuples
  34         fstOf3, sndOf3, thirdOf3,
  35
  36         -- * List operations controlled by another list
  37         takeList, dropList, splitAtList, split,
  38         dropTail,
  39
  40         -- * For loop
  41         nTimes,
  42
  43         -- * Sorting
  44         sortLe, sortWith, on,
  45
  46         -- * Comparisons
  47         isEqual, eqListBy,
  48         thenCmp, cmpList,
  49         removeSpaces,
  50
  51         -- * Edit distance
  52         fuzzyMatch,
  53
  54         -- * Transitive closures
  55         transitiveClosure,
  56
  57         -- * Strictness
  58         seqList,
  59
  60         -- * Module names
  61         looksLikeModuleName,
  62
  63         -- * Argument processing
  64         getCmd, toCmdArgs, toArgs,
  65
  66         -- * Floating point
  67         readRational,
  68
  69         -- * IO-ish utilities
  70         createDirectoryHierarchy,
  71         doesDirNameExist,
  72         modificationTimeIfExists,
  73
  74         global, consIORef, globalMVar, globalEmptyMVar,
  75
  76         -- * Filenames and paths
  77         Suffix,
  78         splitLongestPrefix,
  79         escapeSpaces,
  80         parseSearchPath,
  81         Direction(..), reslash,
  82
  83         -- * Utils for defining Data instances
  84         abstractConstr, abstractDataType, mkNoRepType
  85     ) where
  86
  87 #include "HsVersions.h"
  88
  89 import Exception
  90 import Panic
  91
  92 import Data.Data
  93 import Data.IORef       ( IORef, newIORef, atomicModifyIORef )
  94 import System.IO.Unsafe ( unsafePerformIO )
  95 import Data.List        hiding (group)
  96 import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
  97
  98 #ifdef DEBUG
  99 import FastTypes
 100 #endif
 101
 102 import Control.Monad    ( unless )
 103 import System.IO.Error as IO ( isDoesNotExistError )
 104 import System.Directory ( doesDirectoryExist, createDirectory,
 105                           getModificationTime )
 106 import System.FilePath
 107 import System.Time      ( ClockTime )
 108
 109 import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
 110 import Data.Ratio       ( (%) )
 111 import Data.Ord         ( comparing )
 112 import Data.Bits
 113 import Data.Word
 114 import qualified Data.IntMap as IM
 115
 116 infixr 9 `thenCmp`
 117 \end{code}
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{Is DEBUG on, are we on Windows, etc?}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 These booleans are global constants, set by CPP flags.  They allow us to
 126 recompile a single module (this one) to change whether or not debug output
 127 appears. They sometimes let us avoid even running CPP elsewhere.
 128
 129 It's important that the flags are literal constants (True/False). Then,
 130 with -0, tests of the flags in other modules will simplify to the correct
 131 branch of the conditional, thereby dropping debug code altogether when
 132 the flags are off.
 133
 134 \begin{code}
 135 ghciSupported :: Bool
 136 #ifdef GHCI
 137 ghciSupported = True
 138 #else
 139 ghciSupported = False
 140 #endif
 141
 142 debugIsOn :: Bool
 143 #ifdef DEBUG
 144 debugIsOn = True
 145 #else
 146 debugIsOn = False
 147 #endif
 148
 149 ghciTablesNextToCode :: Bool
 150 #ifdef GHCI_TABLES_NEXT_TO_CODE
 151 ghciTablesNextToCode = True
 152 #else
 153 ghciTablesNextToCode = False
 154 #endif
 155
 156 isDynamicGhcLib :: Bool
 157 #ifdef DYNAMIC
 158 isDynamicGhcLib = True
 159 #else
 160 isDynamicGhcLib = False
 161 #endif
 162
 163 isWindowsHost :: Bool
 164 #ifdef mingw32_HOST_OS
 165 isWindowsHost = True
 166 #else
 167 isWindowsHost = False
 168 #endif
 169
 170 isWindowsTarget :: Bool
 171 #ifdef mingw32_TARGET_OS
 172 isWindowsTarget = True
 173 #else
 174 isWindowsTarget = False
 175 #endif
 176
 177 isDarwinTarget :: Bool
 178 #ifdef darwin_TARGET_OS
 179 isDarwinTarget = True
 180 #else
 181 isDarwinTarget = False
 182 #endif
 183 \end{code}
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection{A for loop}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 \begin{code}
 192 -- | Compose a function with itself n times.  (nth rather than twice)
 193 nTimes :: Int -> (a -> a) -> (a -> a)
 194 nTimes 0 _ = id
 195 nTimes 1 f = f
 196 nTimes n f = f . nTimes (n-1) f
 197 \end{code}
 198
 199 \begin{code}
 200 fstOf3   :: (a,b,c) -> a
 201 sndOf3   :: (a,b,c) -> b
 202 thirdOf3 :: (a,b,c) -> c
 203 fstOf3      (a,_,_) =  a
 204 sndOf3      (_,b,_) =  b
 205 thirdOf3    (_,_,c) =  c
 206 \end{code}
 207
 208 %************************************************************************
 209 %*                                                                      *
 210 \subsection[Utils-lists]{General list processing}
 211 %*                                                                      *
 212 %************************************************************************
 213
 214 \begin{code}
 215 filterOut :: (a->Bool) -> [a] -> [a]
 216 -- ^ Like filter, only it reverses the sense of the test
 217 filterOut _ [] = []
 218 filterOut p (x:xs) | p x       = filterOut p xs
 219                    | otherwise = x : filterOut p xs
 220
 221 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 222 -- ^ Uses a function to determine which of two output lists an input element should join
 223 partitionWith _ [] = ([],[])
 224 partitionWith f (x:xs) = case f x of
 225                          Left  b -> (b:bs, cs)
 226                          Right c -> (bs, c:cs)
 227     where (bs,cs) = partitionWith f xs
 228
 229 splitEithers :: [Either a b] -> ([a], [b])
 230 -- ^ Teases a list of 'Either's apart into two lists
 231 splitEithers [] = ([],[])
 232 splitEithers (e : es) = case e of
 233                         Left x -> (x:xs, ys)
 234                         Right y -> (xs, y:ys)
 235     where (xs,ys) = splitEithers es
 236 \end{code}
 237
 238 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 239 are of equal length.  Alastair Reid thinks this should only happen if
 240 DEBUGging on; hey, why not?
 241
 242 \begin{code}
 243 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 244 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 245 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 246 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 247
 248 #ifndef DEBUG
 249 zipEqual      _ = zip
 250 zipWithEqual  _ = zipWith
 251 zipWith3Equal _ = zipWith3
 252 zipWith4Equal _ = zipWith4
 253 #else
 254 zipEqual _   []     []     = []
 255 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 256 zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
 257
 258 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 259 zipWithEqual _   _ [] []        =  []
 260 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 261
 262 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 263                                 =  z a b c : zipWith3Equal msg z as bs cs
 264 zipWith3Equal _   _ [] []  []   =  []
 265 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 266
 267 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 268                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 269 zipWith4Equal _   _ [] [] [] [] =  []
 270 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 271 #endif
 272 \end{code}
 273
 274 \begin{code}
 275 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
 276 zipLazy :: [a] -> [b] -> [(a,b)]
 277 zipLazy []     _       = []
 278 -- We want to write this, but with GHC 6.4 we get a warning, so it
 279 -- doesn't validate:
 280 -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 281 -- so we write this instead:
 282 zipLazy (x:xs) zs = let y : ys = zs
 283                     in (x,y) : zipLazy xs ys
 284 \end{code}
 285
 286
 287 \begin{code}
 288 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 289 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
 290 -- the places where @p@ returns @True@
 291
 292 stretchZipWith _ _ _ []     _ = []
 293 stretchZipWith p z f (x:xs) ys
 294   | p x       = f x z : stretchZipWith p z f xs ys
 295   | otherwise = case ys of
 296                 []     -> []
 297                 (y:ys) -> f x y : stretchZipWith p z f xs ys
 298 \end{code}
 299
 300
 301 \begin{code}
 302 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
 303 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
 304
 305 mapFst f xys = [(f x, y) | (x,y) <- xys]
 306 mapSnd f xys = [(x, f y) | (x,y) <- xys]
 307
 308 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 309
 310 mapAndUnzip _ [] = ([], [])
 311 mapAndUnzip f (x:xs)
 312   = let (r1,  r2)  = f x
 313         (rs1, rs2) = mapAndUnzip f xs
 314     in
 315     (r1:rs1, r2:rs2)
 316
 317 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 318
 319 mapAndUnzip3 _ [] = ([], [], [])
 320 mapAndUnzip3 f (x:xs)
 321   = let (r1,  r2,  r3)  = f x
 322         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 323     in
 324     (r1:rs1, r2:rs2, r3:rs3)
 325 \end{code}
 326
 327 \begin{code}
 328 nOfThem :: Int -> a -> [a]
 329 nOfThem n thing = replicate n thing
 330
 331 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
 332 --
 333 -- @
 334 --  atLength atLenPred atEndPred ls n
 335 --   | n < 0         = atLenPred n
 336 --   | length ls < n = atEndPred (n - length ls)
 337 --   | otherwise     = atLenPred (drop n ls)
 338 -- @
 339 atLength :: ([a] -> b)
 340          -> (Int -> b)
 341          -> [a]
 342          -> Int
 343          -> b
 344 atLength atLenPred atEndPred ls n
 345   | n < 0     = atEndPred n
 346   | otherwise = go n ls
 347   where
 348     go n [] = atEndPred n
 349     go 0 ls = atLenPred ls
 350     go n (_:xs) = go (n-1) xs
 351
 352 -- Some special cases of atLength:
 353
 354 lengthExceeds :: [a] -> Int -> Bool
 355 -- ^ > (lengthExceeds xs n) = (length xs > n)
 356 lengthExceeds = atLength notNull (const False)
 357
 358 lengthAtLeast :: [a] -> Int -> Bool
 359 lengthAtLeast = atLength notNull (== 0)
 360
 361 lengthIs :: [a] -> Int -> Bool
 362 lengthIs = atLength null (==0)
 363
 364 listLengthCmp :: [a] -> Int -> Ordering
 365 listLengthCmp = atLength atLen atEnd
 366  where
 367   atEnd 0      = EQ
 368   atEnd x
 369    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 370    | otherwise = GT
 371
 372   atLen []     = EQ
 373   atLen _      = GT
 374
 375 equalLength :: [a] -> [b] -> Bool
 376 equalLength []     []     = True
 377 equalLength (_:xs) (_:ys) = equalLength xs ys
 378 equalLength _      _      = False
 379
 380 compareLength :: [a] -> [b] -> Ordering
 381 compareLength []     []     = EQ
 382 compareLength (_:xs) (_:ys) = compareLength xs ys
 383 compareLength []     _      = LT
 384 compareLength _      []     = GT
 385
 386 ----------------------------
 387 singleton :: a -> [a]
 388 singleton x = [x]
 389
 390 isSingleton :: [a] -> Bool
 391 isSingleton [_] = True
 392 isSingleton _   = False
 393
 394 notNull :: [a] -> Bool
 395 notNull [] = False
 396 notNull _  = True
 397
 398 only :: [a] -> a
 399 #ifdef DEBUG
 400 only [a] = a
 401 #else
 402 only (a:_) = a
 403 #endif
 404 only _ = panic "Util: only"
 405 \end{code}
 406
 407 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 408
 409 \begin{code}
 410 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
 411
 412 # ifndef DEBUG
 413 isIn    _msg x ys = x `elem` ys
 414 isn'tIn _msg x ys = x `notElem` ys
 415
 416 # else /* DEBUG */
 417 isIn msg x ys
 418   = elem100 (_ILIT(0)) x ys
 419   where
 420     elem100 _ _ []        = False
 421     elem100 i x (y:ys)
 422       | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
 423                                 (x `elem` (y:ys))
 424       | otherwise       = x == y || elem100 (i +# _ILIT(1)) x ys
 425
 426 isn'tIn msg x ys
 427   = notElem100 (_ILIT(0)) x ys
 428   where
 429     notElem100 _ _ [] =  True
 430     notElem100 i x (y:ys)
 431       | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
 432                                 (x `notElem` (y:ys))
 433       | otherwise      =  x /= y && notElem100 (i +# _ILIT(1)) x ys
 434 # endif /* DEBUG */
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{display}
 444 Date: Mon, 3 May 93 20:45:23 +0200
 445 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 446 To: partain@dcs.gla.ac.uk
 447 Subject: natural merge sort beats quick sort [ and it is prettier ]
 448
 449 Here is a piece of Haskell code that I'm rather fond of. See it as an
 450 attempt to get rid of the ridiculous quick-sort routine. group is
 451 quite useful by itself I think it was John's idea originally though I
 452 believe the lazy version is due to me [surprisingly complicated].
 453 gamma [used to be called] is called gamma because I got inspired by
 454 the Gamma calculus. It is not very close to the calculus but does
 455 behave less sequentially than both foldr and foldl. One could imagine
 456 a version of gamma that took a unit element as well thereby avoiding
 457 the problem with empty lists.
 458
 459 I've tried this code against
 460
 461    1) insertion sort - as provided by haskell
 462    2) the normal implementation of quick sort
 463    3) a deforested version of quick sort due to Jan Sparud
 464    4) a super-optimized-quick-sort of Lennart's
 465
 466 If the list is partially sorted both merge sort and in particular
 467 natural merge sort wins. If the list is random [ average length of
 468 rising subsequences = approx 2 ] mergesort still wins and natural
 469 merge sort is marginally beaten by Lennart's soqs. The space
 470 consumption of merge sort is a bit worse than Lennart's quick sort
 471 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 472 fpca article ] isn't used because of group.
 473
 474 have fun
 475 Carsten
 476 \end{display}
 477
 478 \begin{code}
 479 group :: (a -> a -> Bool) -> [a] -> [[a]]
 480 -- Given a <= function, group finds maximal contiguous up-runs
 481 -- or down-runs in the input list.
 482 -- It's stable, in the sense that it never re-orders equal elements
 483 --
 484 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 485 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 486 -- Here is a `better' definition of group.
 487
 488 group _ []     = []
 489 group p (x:xs) = group' xs x x (x :)
 490   where
 491     group' []     _     _     s  = [s []]
 492     group' (x:xs) x_min x_max s
 493         |      x_max `p` x  = group' xs x_min x     (s . (x :))
 494         | not (x_min `p` x) = group' xs x     x_max ((x :) . s)
 495         | otherwise         = s [] : group' xs x x (x :)
 496         -- NB: the 'not' is essential for stablity
 497         --     x `p` x_min would reverse equal elements
 498
 499 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 500 generalMerge _ xs [] = xs
 501 generalMerge _ [] ys = ys
 502 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
 503                              | otherwise = y : generalMerge p (x:xs) ys
 504
 505 -- gamma is now called balancedFold
 506
 507 balancedFold :: (a -> a -> a) -> [a] -> a
 508 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
 509 balancedFold _ [x] = x
 510 balancedFold f l  = balancedFold f (balancedFold' f l)
 511
 512 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 513 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 514 balancedFold' _ xs = xs
 515
 516 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
 517 generalNaturalMergeSort _ [] = []
 518 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 519
 520 #if NOT_USED
 521 generalMergeSort p [] = []
 522 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 523
 524 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 525
 526 mergeSort = generalMergeSort (<=)
 527 naturalMergeSort = generalNaturalMergeSort (<=)
 528
 529 mergeSortLe le = generalMergeSort le
 530 #endif
 531
 532 sortLe :: (a->a->Bool) -> [a] -> [a]
 533 sortLe le = generalNaturalMergeSort le
 534
 535 sortWith :: Ord b => (a->b) -> [a] -> [a]
 536 sortWith get_key xs = sortLe le xs
 537   where
 538     x `le` y = get_key x < get_key y
 539
 540 on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
 541 on cmp sel = \x y -> sel x `cmp` sel y
 542
 543 \end{code}
 544
 545 %************************************************************************
 546 %*                                                                      *
 547 \subsection[Utils-transitive-closure]{Transitive closure}
 548 %*                                                                      *
 549 %************************************************************************
 550
 551 This algorithm for transitive closure is straightforward, albeit quadratic.
 552
 553 \begin{code}
 554 transitiveClosure :: (a -> [a])         -- Successor function
 555                   -> (a -> a -> Bool)   -- Equality predicate
 556                   -> [a]
 557                   -> [a]                -- The transitive closure
 558
 559 transitiveClosure succ eq xs
 560  = go [] xs
 561  where
 562    go done []                      = done
 563    go done (x:xs) | x `is_in` done = go done xs
 564                   | otherwise      = go (x:done) (succ x ++ xs)
 565
 566    _ `is_in` []                 = False
 567    x `is_in` (y:ys) | eq x y    = True
 568                     | otherwise = x `is_in` ys
 569 \end{code}
 570
 571 %************************************************************************
 572 %*                                                                      *
 573 \subsection[Utils-accum]{Accumulating}
 574 %*                                                                      *
 575 %************************************************************************
 576
 577 A combination of foldl with zip.  It works with equal length lists.
 578
 579 \begin{code}
 580 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 581 foldl2 _ z [] [] = z
 582 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 583 foldl2 _ _ _      _      = panic "Util: foldl2"
 584
 585 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 586 -- True if the lists are the same length, and
 587 -- all corresponding elements satisfy the predicate
 588 all2 _ []     []     = True
 589 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 590 all2 _ _      _      = False
 591 \end{code}
 592
 593 Count the number of times a predicate is true
 594
 595 \begin{code}
 596 count :: (a -> Bool) -> [a] -> Int
 597 count _ [] = 0
 598 count p (x:xs) | p x       = 1 + count p xs
 599                | otherwise = count p xs
 600 \end{code}
 601
 602 @splitAt@, @take@, and @drop@ but with length of another
 603 list giving the break-off point:
 604
 605 \begin{code}
 606 takeList :: [b] -> [a] -> [a]
 607 takeList [] _ = []
 608 takeList (_:xs) ls =
 609    case ls of
 610      [] -> []
 611      (y:ys) -> y : takeList xs ys
 612
 613 dropList :: [b] -> [a] -> [a]
 614 dropList [] xs    = xs
 615 dropList _  xs@[] = xs
 616 dropList (_:xs) (_:ys) = dropList xs ys
 617
 618
 619 splitAtList :: [b] -> [a] -> ([a], [a])
 620 splitAtList [] xs     = ([], xs)
 621 splitAtList _ xs@[]   = (xs, xs)
 622 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 623     where
 624       (ys', ys'') = splitAtList xs ys
 625
 626 -- drop from the end of a list
 627 dropTail :: Int -> [a] -> [a]
 628 dropTail n = reverse . drop n . reverse
 629
 630 snocView :: [a] -> Maybe ([a],a)
 631         -- Split off the last element
 632 snocView [] = Nothing
 633 snocView xs = go [] xs
 634             where
 635                 -- Invariant: second arg is non-empty
 636               go acc [x]    = Just (reverse acc, x)
 637               go acc (x:xs) = go (x:acc) xs
 638               go _   []     = panic "Util: snocView"
 639
 640 split :: Char -> String -> [String]
 641 split c s = case rest of
 642                 []     -> [chunk]
 643                 _:rest -> chunk : split c rest
 644   where (chunk, rest) = break (==c) s
 645 \end{code}
 646
 647
 648 %************************************************************************
 649 %*                                                                      *
 650 \subsection[Utils-comparison]{Comparisons}
 651 %*                                                                      *
 652 %************************************************************************
 653
 654 \begin{code}
 655 isEqual :: Ordering -> Bool
 656 -- Often used in (isEqual (a `compare` b))
 657 isEqual GT = False
 658 isEqual EQ = True
 659 isEqual LT = False
 660
 661 thenCmp :: Ordering -> Ordering -> Ordering
 662 {-# INLINE thenCmp #-}
 663 thenCmp EQ       ordering = ordering
 664 thenCmp ordering _        = ordering
 665
 666 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 667 eqListBy _  []     []     = True
 668 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 669 eqListBy _  _      _      = False
 670
 671 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 672     -- `cmpList' uses a user-specified comparer
 673
 674 cmpList _   []     [] = EQ
 675 cmpList _   []     _  = LT
 676 cmpList _   _      [] = GT
 677 cmpList cmp (a:as) (b:bs)
 678   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 679 \end{code}
 680
 681 \begin{code}
 682 removeSpaces :: String -> String
 683 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 684 \end{code}
 685
 686 %************************************************************************
 687 %*                                                                      *
 688 \subsection{Edit distance}
 689 %*                                                                      *
 690 %************************************************************************
 691
 692 \begin{code}
 693 -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.
 694 -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).
 695 -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation
 696 restrictedDamerauLevenshteinDistance :: String -> String -> Int
 697 restrictedDamerauLevenshteinDistance str1 str2 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
 698   where
 699     m = length str1
 700     n = length str2
 701
 702 restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int
 703 restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
 704   | m <= n    = if n <= 32 -- n must be larger so this check is sufficient
 705                 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2
 706                 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2
 707   | otherwise = if m <= 32 -- m must be larger so this check is sufficient
 708                 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1
 709                 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1
 710
 711 restrictedDamerauLevenshteinDistance' :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int
 712 restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
 713   | [] <- str1 = n
 714   | otherwise  = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2
 715   where m_ones@vector_mask = (2 ^ m) - 1
 716         top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy
 717         extractAnswer (_, _, _, _, distance) = distance
 718
 719 restrictedDamerauLevenshteinDistanceWorker :: (Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
 720 restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2
 721   = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ seq pm' $ seq d0' $ seq vp' $ seq vn' $ seq distance'' $ seq char2 $ (pm', d0', vp', vn', distance'')
 722   where
 723     pm' = IM.findWithDefault 0 (ord char2) str1_mvs
 724
 725     d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) -- No need to mask the shiftL because of the restricted range of pm
 726       .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn
 727     hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)
 728     hn' = d0' .&. vp
 729
 730     hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask
 731     hn'_shift = (hn' `shiftL` 1) .&. vector_mask
 732     vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)
 733     vn' = d0' .&. hp'_shift
 734
 735     distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance
 736     distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
 737
 738 sizedComplement :: Bits bv => bv -> bv -> bv
 739 sizedComplement vector_mask vect = vector_mask `xor` vect
 740
 741 matchVectors :: Bits bv => String -> IM.IntMap bv
 742 matchVectors = snd . foldl' go (0 :: Int, IM.empty)
 743   where
 744     go (ix, im) char = let ix' = ix + 1
 745                            im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im
 746                        in seq ix' $ seq im' $ (ix', im')
 747
 748 #ifdef __GLASGOW_HASKELL__
 749 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-}
 750 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-}
 751
 752 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-}
 753 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-}
 754
 755 {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}
 756 {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}
 757
 758 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}
 759 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}
 760 #endif
 761
 762 -- | Search for possible matches to the users input in the given list, returning a small number of ranked results
 763 fuzzyMatch :: String -> [String] -> [String]
 764 fuzzyMatch user_entered possibilites = map fst $ take mAX_RESULTS $ sortBy (comparing snd)
 765                                                 [ (poss, distance) | poss <- possibilites
 766                                                                    , let distance = restrictedDamerauLevenshteinDistance poss user_entered
 767                                                                    , distance <= fuzzy_threshold ]
 768   where -- Work out an approriate match threshold (about a quarter of the # of characters the user entered)
 769         fuzzy_threshold = max (round $ fromInteger (genericLength user_entered) / (4 :: Rational)) 1
 770         mAX_RESULTS = 3
 771 \end{code}
 772
 773 %************************************************************************
 774 %*                                                                      *
 775 \subsection[Utils-pairs]{Pairs}
 776 %*                                                                      *
 777 %************************************************************************
 778
 779 \begin{code}
 780 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 781 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 782 \end{code}
 783
 784 \begin{code}
 785 seqList :: [a] -> b -> b
 786 seqList [] b = b
 787 seqList (x:xs) b = x `seq` seqList xs b
 788 \end{code}
 789
 790 Global variables:
 791
 792 \begin{code}
 793 global :: a -> IORef a
 794 global a = unsafePerformIO (newIORef a)
 795 \end{code}
 796
 797 \begin{code}
 798 consIORef :: IORef [a] -> a -> IO ()
 799 consIORef var x = do
 800   atomicModifyIORef var (\xs -> (x:xs,()))
 801 \end{code}
 802
 803 \begin{code}
 804 globalMVar :: a -> MVar a
 805 globalMVar a = unsafePerformIO (newMVar a)
 806
 807 globalEmptyMVar :: MVar a
 808 globalEmptyMVar = unsafePerformIO newEmptyMVar
 809 \end{code}
 810
 811 Module names:
 812
 813 \begin{code}
 814 looksLikeModuleName :: String -> Bool
 815 looksLikeModuleName [] = False
 816 looksLikeModuleName (c:cs) = isUpper c && go cs
 817   where go [] = True
 818         go ('.':cs) = looksLikeModuleName cs
 819         go (c:cs)   = (isAlphaNum c || c == '_' || c == '\'') && go cs
 820 \end{code}
 821
 822 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 823 quoted strings as Haskell Strings, and also parses Haskell [String]
 824 syntax.
 825
 826 \begin{code}
 827 getCmd :: String -> Either String             -- Error
 828                            (String, String) -- (Cmd, Rest)
 829 getCmd s = case break isSpace $ dropWhile isSpace s of
 830            ([], _) -> Left ("Couldn't find command in " ++ show s)
 831            res -> Right res
 832
 833 toCmdArgs :: String -> Either String             -- Error
 834                               (String, [String]) -- (Cmd, Args)
 835 toCmdArgs s = case getCmd s of
 836               Left err -> Left err
 837               Right (cmd, s') -> case toArgs s' of
 838                                  Left err -> Left err
 839                                  Right args -> Right (cmd, args)
 840
 841 toArgs :: String -> Either String   -- Error
 842                            [String] -- Args
 843 toArgs str
 844     = case dropWhile isSpace str of
 845       s@('[':_) -> case reads s of
 846                    [(args, spaces)]
 847                     | all isSpace spaces ->
 848                        Right args
 849                    _ ->
 850                        Left ("Couldn't read " ++ show str ++ "as [String]")
 851       s -> toArgs' s
 852  where
 853   toArgs' s = case dropWhile isSpace s of
 854               [] -> Right []
 855               ('"' : _) -> case reads s of
 856                            [(arg, rest)]
 857                               -- rest must either be [] or start with a space
 858                             | all isSpace (take 1 rest) ->
 859                                case toArgs' rest of
 860                                Left err -> Left err
 861                                Right args -> Right (arg : args)
 862                            _ ->
 863                                Left ("Couldn't read " ++ show s ++ "as String")
 864               s' -> case break isSpace s' of
 865                     (arg, s'') -> case toArgs' s'' of
 866                                   Left err -> Left err
 867                                   Right args -> Right (arg : args)
 868 \end{code}
 869
 870 -- -----------------------------------------------------------------------------
 871 -- Floats
 872
 873 \begin{code}
 874 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 875 readRational__ r = do
 876      (n,d,s) <- readFix r
 877      (k,t)   <- readExp s
 878      return ((n%1)*10^^(k-d), t)
 879  where
 880      readFix r = do
 881         (ds,s)  <- lexDecDigits r
 882         (ds',t) <- lexDotDigits s
 883         return (read (ds++ds'), length ds', t)
 884
 885      readExp (e:s) | e `elem` "eE" = readExp' s
 886      readExp s                     = return (0,s)
 887
 888      readExp' ('+':s) = readDec s
 889      readExp' ('-':s) = do (k,t) <- readDec s
 890                            return (-k,t)
 891      readExp' s       = readDec s
 892
 893      readDec s = do
 894         (ds,r) <- nonnull isDigit s
 895         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 896                 r)
 897
 898      lexDecDigits = nonnull isDigit
 899
 900      lexDotDigits ('.':s) = return (span isDigit s)
 901      lexDotDigits s       = return ("",s)
 902
 903      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 904                       return (cs,t)
 905
 906 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 907 readRational top_s
 908   = case top_s of
 909       '-' : xs -> - (read_me xs)
 910       xs       -> read_me xs
 911   where
 912     read_me s
 913       = case (do { (x,"") <- readRational__ s ; return x }) of
 914           [x] -> x
 915           []  -> error ("readRational: no parse:"        ++ top_s)
 916           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 917
 918
 919 -----------------------------------------------------------------------------
 920 -- Create a hierarchy of directories
 921
 922 createDirectoryHierarchy :: FilePath -> IO ()
 923 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
 924 createDirectoryHierarchy dir = do
 925   b <- doesDirectoryExist dir
 926   unless b $ do createDirectoryHierarchy (takeDirectory dir)
 927                 createDirectory dir
 928
 929 -----------------------------------------------------------------------------
 930 -- Verify that the 'dirname' portion of a FilePath exists.
 931 --
 932 doesDirNameExist :: FilePath -> IO Bool
 933 doesDirNameExist fpath = case takeDirectory fpath of
 934                          "" -> return True -- XXX Hack
 935                          _  -> doesDirectoryExist (takeDirectory fpath)
 936
 937 -- --------------------------------------------------------------
 938 -- check existence & modification time at the same time
 939
 940 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 941 modificationTimeIfExists f = do
 942   (do t <- getModificationTime f; return (Just t))
 943         `catchIO` \e -> if isDoesNotExistError e
 944                         then return Nothing
 945                         else ioError e
 946
 947 -- split a string at the last character where 'pred' is True,
 948 -- returning a pair of strings. The first component holds the string
 949 -- up (but not including) the last character for which 'pred' returned
 950 -- True, the second whatever comes after (but also not including the
 951 -- last character).
 952 --
 953 -- If 'pred' returns False for all characters in the string, the original
 954 -- string is returned in the first component (and the second one is just
 955 -- empty).
 956 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 957 splitLongestPrefix str pred
 958   | null r_pre = (str,           [])
 959   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 960                            -- 'tail' drops the char satisfying 'pred'
 961   where (r_suf, r_pre) = break pred (reverse str)
 962
 963 escapeSpaces :: String -> String
 964 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 965
 966 type Suffix = String
 967
 968 --------------------------------------------------------------
 969 -- * Search path
 970 --------------------------------------------------------------
 971
 972 -- | The function splits the given string to substrings
 973 -- using the 'searchPathSeparator'.
 974 parseSearchPath :: String -> [FilePath]
 975 parseSearchPath path = split path
 976   where
 977     split :: String -> [String]
 978     split s =
 979       case rest' of
 980         []     -> [chunk]
 981         _:rest -> chunk : split rest
 982       where
 983         chunk =
 984           case chunk' of
 985 #ifdef mingw32_HOST_OS
 986             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 987 #endif
 988             _                                 -> chunk'
 989
 990         (chunk', rest') = break isSearchPathSeparator s
 991
 992 data Direction = Forwards | Backwards
 993
 994 reslash :: Direction -> FilePath -> FilePath
 995 reslash d = f
 996     where f ('/'  : xs) = slash : f xs
 997           f ('\\' : xs) = slash : f xs
 998           f (x    : xs) = x     : f xs
 999           f ""          = ""
1000           slash = case d of
1001                   Forwards -> '/'
1002                   Backwards -> '\\'
1003 \end{code}
1004
1005 %************************************************************************
1006 %*                                                                      *
1007 \subsection[Utils-Data]{Utils for defining Data instances}
1008 %*                                                                      *
1009 %************************************************************************
1010
1011 These functions helps us to define Data instances for abstract types.
1012
1013 \begin{code}
1014 abstractConstr :: String -> Constr
1015 abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
1016 \end{code}
1017
1018 \begin{code}
1019 abstractDataType :: String -> DataType
1020 abstractDataType n = mkDataType n [abstractConstr n]
1021 \end{code}
1022