1-- (c) The University of Glasgow 2006 2 3{-# LANGUAGE CPP #-} 4{-# LANGUAGE KindSignatures #-} 5{-# LANGUAGE ConstraintKinds #-} 6{-# LANGUAGE BangPatterns #-} 7{-# LANGUAGE TupleSections #-} 8 9-- | Highly random utility functions 10-- 11module Util ( 12 -- * Flags dependent on the compiler build 13 ghciSupported, debugIsOn, 14 ghciTablesNextToCode, 15 isWindowsHost, isDarwinHost, 16 17 -- * Miscellaneous higher-order functions 18 applyWhen, nTimes, 19 20 -- * General list processing 21 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, 22 zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, 23 24 zipWithLazy, zipWith3Lazy, 25 26 filterByList, filterByLists, partitionByList, 27 28 unzipWith, 29 30 mapFst, mapSnd, chkAppend, 31 mapAndUnzip, mapAndUnzip3, mapAccumL2, 32 filterOut, partitionWith, 33 34 dropWhileEndLE, spanEnd, last2, lastMaybe, 35 36 foldl1', foldl2, count, countWhile, all2, 37 38 lengthExceeds, lengthIs, lengthIsNot, 39 lengthAtLeast, lengthAtMost, lengthLessThan, 40 listLengthCmp, atLength, 41 equalLength, compareLength, leLength, ltLength, 42 43 isSingleton, only, singleton, 44 notNull, snocView, 45 46 isIn, isn'tIn, 47 48 chunkList, 49 50 changeLast, 51 52 whenNonEmpty, 53 54 -- * Tuples 55 fstOf3, sndOf3, thdOf3, 56 firstM, first3M, secondM, 57 fst3, snd3, third3, 58 uncurry3, 59 liftFst, liftSnd, 60 61 -- * List operations controlled by another list 62 takeList, dropList, splitAtList, split, 63 dropTail, capitalise, 64 65 -- * Sorting 66 sortWith, minWith, nubSort, ordNub, 67 68 -- * Comparisons 69 isEqual, eqListBy, eqMaybeBy, 70 thenCmp, cmpList, 71 removeSpaces, 72 (<&&>), (<||>), 73 74 -- * Edit distance 75 fuzzyMatch, fuzzyLookup, 76 77 -- * Transitive closures 78 transitiveClosure, 79 80 -- * Strictness 81 seqList, 82 83 -- * Module names 84 looksLikeModuleName, 85 looksLikePackageName, 86 87 -- * Argument processing 88 getCmd, toCmdArgs, toArgs, 89 90 -- * Integers 91 exactLog2, 92 93 -- * Floating point 94 readRational, 95 readHexRational, 96 97 -- * IO-ish utilities 98 doesDirNameExist, 99 getModificationUTCTime, 100 modificationTimeIfExists, 101 withAtomicRename, 102 103 global, consIORef, globalM, 104 sharedGlobal, sharedGlobalM, 105 106 -- * Filenames and paths 107 Suffix, 108 splitLongestPrefix, 109 escapeSpaces, 110 Direction(..), reslash, 111 makeRelativeTo, 112 113 -- * Utils for defining Data instances 114 abstractConstr, abstractDataType, mkNoRepType, 115 116 -- * Utils for printing C code 117 charToC, 118 119 -- * Hashing 120 hashString, 121 122 -- * Call stacks 123 HasCallStack, 124 HasDebugCallStack, 125 126 -- * Utils for flags 127 OverridingBool(..), 128 overrideWith, 129 ) where 130 131#include "GhclibHsVersions.h" 132 133import GhcPrelude 134 135import Exception 136import PlainPanic 137 138import Data.Data 139import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) 140import System.IO.Unsafe ( unsafePerformIO ) 141import Data.List hiding (group) 142import Data.List.NonEmpty ( NonEmpty(..) ) 143 144import GHC.Exts 145import GHC.Stack (HasCallStack) 146 147import Control.Applicative ( liftA2 ) 148import Control.Monad ( liftM, guard ) 149import Control.Monad.IO.Class ( MonadIO, liftIO ) 150import GHC.Conc.Sync ( sharedCAF ) 151import System.IO.Error as IO ( isDoesNotExistError ) 152import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) 153import System.FilePath 154 155import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper 156 , isHexDigit, digitToInt ) 157import Data.Int 158import Data.Ratio ( (%) ) 159import Data.Ord ( comparing ) 160import Data.Bits 161import Data.Word 162import qualified Data.IntMap as IM 163import qualified Data.Set as Set 164 165import Data.Time 166 167#if defined(DEBUG) 168import {-# SOURCE #-} Outputable ( warnPprTrace, text ) 169#endif 170 171infixr 9 `thenCmp` 172 173{- 174************************************************************************ 175* * 176\subsection{Is DEBUG on, are we on Windows, etc?} 177* * 178************************************************************************ 179 180These booleans are global constants, set by CPP flags. They allow us to 181recompile a single module (this one) to change whether or not debug output 182appears. They sometimes let us avoid even running CPP elsewhere. 183 184It's important that the flags are literal constants (True/False). Then, 185with -0, tests of the flags in other modules will simplify to the correct 186branch of the conditional, thereby dropping debug code altogether when 187the flags are off. 188-} 189 190ghciSupported :: Bool 191#if defined(HAVE_INTERNAL_INTERPRETER) 192ghciSupported = True 193#else 194ghciSupported = False 195#endif 196 197debugIsOn :: Bool 198#if defined(DEBUG) 199debugIsOn = True 200#else 201debugIsOn = False 202#endif 203 204ghciTablesNextToCode :: Bool 205#if defined(GHCI_TABLES_NEXT_TO_CODE) 206ghciTablesNextToCode = True 207#else 208ghciTablesNextToCode = False 209#endif 210 211isWindowsHost :: Bool 212#if defined(mingw32_HOST_OS) 213isWindowsHost = True 214#else 215isWindowsHost = False 216#endif 217 218isDarwinHost :: Bool 219#if defined(darwin_HOST_OS) 220isDarwinHost = True 221#else 222isDarwinHost = False 223#endif 224 225{- 226************************************************************************ 227* * 228\subsection{Miscellaneous higher-order functions} 229* * 230************************************************************************ 231-} 232 233-- | Apply a function iff some condition is met. 234applyWhen :: Bool -> (a -> a) -> a -> a 235applyWhen True f x = f x 236applyWhen _ _ x = x 237 238-- | A for loop: Compose a function with itself n times. (nth rather than twice) 239nTimes :: Int -> (a -> a) -> (a -> a) 240nTimes 0 _ = id 241nTimes 1 f = f 242nTimes n f = f . nTimes (n-1) f 243 244fstOf3 :: (a,b,c) -> a 245sndOf3 :: (a,b,c) -> b 246thdOf3 :: (a,b,c) -> c 247fstOf3 (a,_,_) = a 248sndOf3 (_,b,_) = b 249thdOf3 (_,_,c) = c 250 251fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) 252fst3 f (a, b, c) = (f a, b, c) 253 254snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) 255snd3 f (a, b, c) = (a, f b, c) 256 257third3 :: (c -> d) -> (a, b, c) -> (a, b, d) 258third3 f (a, b, c) = (a, b, f c) 259 260uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 261uncurry3 f (a, b, c) = f a b c 262 263liftFst :: (a -> b) -> (a, c) -> (b, c) 264liftFst f (a,c) = (f a, c) 265 266liftSnd :: (a -> b) -> (c, a) -> (c, b) 267liftSnd f (c,a) = (c, f a) 268 269firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) 270firstM f (x, y) = liftM (\x' -> (x', y)) (f x) 271 272first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) 273first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) 274 275secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) 276secondM f (x, y) = (x,) <$> f y 277 278{- 279************************************************************************ 280* * 281\subsection[Utils-lists]{General list processing} 282* * 283************************************************************************ 284-} 285 286filterOut :: (a->Bool) -> [a] -> [a] 287-- ^ Like filter, only it reverses the sense of the test 288filterOut _ [] = [] 289filterOut p (x:xs) | p x = filterOut p xs 290 | otherwise = x : filterOut p xs 291 292partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) 293-- ^ Uses a function to determine which of two output lists an input element should join 294partitionWith _ [] = ([],[]) 295partitionWith f (x:xs) = case f x of 296 Left b -> (b:bs, cs) 297 Right c -> (bs, c:cs) 298 where (bs,cs) = partitionWith f xs 299 300chkAppend :: [a] -> [a] -> [a] 301-- Checks for the second argument being empty 302-- Used in situations where that situation is common 303chkAppend xs ys 304 | null ys = xs 305 | otherwise = xs ++ ys 306 307{- 308A paranoid @zip@ (and some @zipWith@ friends) that checks the lists 309are of equal length. Alastair Reid thinks this should only happen if 310DEBUGging on; hey, why not? 311-} 312 313zipEqual :: String -> [a] -> [b] -> [(a,b)] 314zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] 315zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] 316zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] 317 318#if !defined(DEBUG) 319zipEqual _ = zip 320zipWithEqual _ = zipWith 321zipWith3Equal _ = zipWith3 322zipWith4Equal _ = zipWith4 323#else 324zipEqual _ [] [] = [] 325zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs 326zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) 327 328zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs 329zipWithEqual _ _ [] [] = [] 330zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) 331 332zipWith3Equal msg z (a:as) (b:bs) (c:cs) 333 = z a b c : zipWith3Equal msg z as bs cs 334zipWith3Equal _ _ [] [] [] = [] 335zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) 336 337zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) 338 = z a b c d : zipWith4Equal msg z as bs cs ds 339zipWith4Equal _ _ [] [] [] [] = [] 340zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) 341#endif 342 343-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) 344zipLazy :: [a] -> [b] -> [(a,b)] 345zipLazy [] _ = [] 346zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys 347 348-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. 349-- The length of the output is always the same as the length of the first 350-- list. 351zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] 352zipWithLazy _ [] _ = [] 353zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs 354 355-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. 356-- The length of the output is always the same as the length of the first 357-- list. 358zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] 359zipWith3Lazy _ [] _ _ = [] 360zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs 361 362-- | 'filterByList' takes a list of Bools and a list of some elements and 363-- filters out these elements for which the corresponding value in the list of 364-- Bools is False. This function does not check whether the lists have equal 365-- length. 366filterByList :: [Bool] -> [a] -> [a] 367filterByList (True:bs) (x:xs) = x : filterByList bs xs 368filterByList (False:bs) (_:xs) = filterByList bs xs 369filterByList _ _ = [] 370 371-- | 'filterByLists' takes a list of Bools and two lists as input, and 372-- outputs a new list consisting of elements from the last two input lists. For 373-- each Bool in the list, if it is 'True', then it takes an element from the 374-- former list. If it is 'False', it takes an element from the latter list. 375-- The elements taken correspond to the index of the Bool in its list. 376-- For example: 377-- 378-- @ 379-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" 380-- @ 381-- 382-- This function does not check whether the lists have equal length. 383filterByLists :: [Bool] -> [a] -> [a] -> [a] 384filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys 385filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys 386filterByLists _ _ _ = [] 387 388-- | 'partitionByList' takes a list of Bools and a list of some elements and 389-- partitions the list according to the list of Bools. Elements corresponding 390-- to 'True' go to the left; elements corresponding to 'False' go to the right. 391-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ 392-- This function does not check whether the lists have equal 393-- length; when one list runs out, the function stops. 394partitionByList :: [Bool] -> [a] -> ([a], [a]) 395partitionByList = go [] [] 396 where 397 go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs 398 go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs 399 go trues falses _ _ = (reverse trues, reverse falses) 400 401stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] 402-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in 403-- the places where @p@ returns @True@ 404 405stretchZipWith _ _ _ [] _ = [] 406stretchZipWith p z f (x:xs) ys 407 | p x = f x z : stretchZipWith p z f xs ys 408 | otherwise = case ys of 409 [] -> [] 410 (y:ys) -> f x y : stretchZipWith p z f xs ys 411 412mapFst :: (a->c) -> [(a,b)] -> [(c,b)] 413mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] 414 415mapFst f xys = [(f x, y) | (x,y) <- xys] 416mapSnd f xys = [(x, f y) | (x,y) <- xys] 417 418mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) 419 420mapAndUnzip _ [] = ([], []) 421mapAndUnzip f (x:xs) 422 = let (r1, r2) = f x 423 (rs1, rs2) = mapAndUnzip f xs 424 in 425 (r1:rs1, r2:rs2) 426 427mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) 428 429mapAndUnzip3 _ [] = ([], [], []) 430mapAndUnzip3 f (x:xs) 431 = let (r1, r2, r3) = f x 432 (rs1, rs2, rs3) = mapAndUnzip3 f xs 433 in 434 (r1:rs1, r2:rs2, r3:rs3) 435 436zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) 437zipWithAndUnzip f (a:as) (b:bs) 438 = let (r1, r2) = f a b 439 (rs1, rs2) = zipWithAndUnzip f as bs 440 in 441 (r1:rs1, r2:rs2) 442zipWithAndUnzip _ _ _ = ([],[]) 443 444-- | This has the effect of making the two lists have equal length by dropping 445-- the tail of the longer one. 446zipAndUnzip :: [a] -> [b] -> ([a],[b]) 447zipAndUnzip (a:as) (b:bs) 448 = let (rs1, rs2) = zipAndUnzip as bs 449 in 450 (a:rs1, b:rs2) 451zipAndUnzip _ _ = ([],[]) 452 453mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) 454mapAccumL2 f s1 s2 xs = (s1', s2', ys) 455 where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of 456 (s1', s2', y) -> ((s1', s2'), y)) 457 (s1, s2) xs 458 459-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: 460-- 461-- @ 462-- atLength atLenPred atEndPred ls n 463-- | n < 0 = atLenPred ls 464-- | length ls < n = atEndPred (n - length ls) 465-- | otherwise = atLenPred (drop n ls) 466-- @ 467atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) 468 -- NB: arg passed to this function may be [] 469 -> b -- Called when length ls < n 470 -> [a] 471 -> Int 472 -> b 473atLength atLenPred atEnd ls0 n0 474 | n0 < 0 = atLenPred ls0 475 | otherwise = go n0 ls0 476 where 477 -- go's first arg n >= 0 478 go 0 ls = atLenPred ls 479 go _ [] = atEnd -- n > 0 here 480 go n (_:xs) = go (n-1) xs 481 482-- Some special cases of atLength: 483 484-- | @(lengthExceeds xs n) = (length xs > n)@ 485lengthExceeds :: [a] -> Int -> Bool 486lengthExceeds lst n 487 | n < 0 488 = True 489 | otherwise 490 = atLength notNull False lst n 491 492-- | @(lengthAtLeast xs n) = (length xs >= n)@ 493lengthAtLeast :: [a] -> Int -> Bool 494lengthAtLeast = atLength (const True) False 495 496-- | @(lengthIs xs n) = (length xs == n)@ 497lengthIs :: [a] -> Int -> Bool 498lengthIs lst n 499 | n < 0 500 = False 501 | otherwise 502 = atLength null False lst n 503 504-- | @(lengthIsNot xs n) = (length xs /= n)@ 505lengthIsNot :: [a] -> Int -> Bool 506lengthIsNot lst n 507 | n < 0 = True 508 | otherwise = atLength notNull True lst n 509 510-- | @(lengthAtMost xs n) = (length xs <= n)@ 511lengthAtMost :: [a] -> Int -> Bool 512lengthAtMost lst n 513 | n < 0 514 = False 515 | otherwise 516 = atLength null True lst n 517 518-- | @(lengthLessThan xs n) == (length xs < n)@ 519lengthLessThan :: [a] -> Int -> Bool 520lengthLessThan = atLength (const False) True 521 522listLengthCmp :: [a] -> Int -> Ordering 523listLengthCmp = atLength atLen atEnd 524 where 525 atEnd = LT -- Not yet seen 'n' elts, so list length is < n. 526 527 atLen [] = EQ 528 atLen _ = GT 529 530equalLength :: [a] -> [b] -> Bool 531-- ^ True if length xs == length ys 532equalLength [] [] = True 533equalLength (_:xs) (_:ys) = equalLength xs ys 534equalLength _ _ = False 535 536compareLength :: [a] -> [b] -> Ordering 537compareLength [] [] = EQ 538compareLength (_:xs) (_:ys) = compareLength xs ys 539compareLength [] _ = LT 540compareLength _ [] = GT 541 542leLength :: [a] -> [b] -> Bool 543-- ^ True if length xs <= length ys 544leLength xs ys = case compareLength xs ys of 545 LT -> True 546 EQ -> True 547 GT -> False 548 549ltLength :: [a] -> [b] -> Bool 550-- ^ True if length xs < length ys 551ltLength xs ys = case compareLength xs ys of 552 LT -> True 553 EQ -> False 554 GT -> False 555 556---------------------------- 557singleton :: a -> [a] 558singleton x = [x] 559 560isSingleton :: [a] -> Bool 561isSingleton [_] = True 562isSingleton _ = False 563 564notNull :: [a] -> Bool 565notNull [] = False 566notNull _ = True 567 568only :: [a] -> a 569#if defined(DEBUG) 570only [a] = a 571#else 572only (a:_) = a 573#endif 574only _ = panic "Util: only" 575 576-- Debugging/specialising versions of \tr{elem} and \tr{notElem} 577 578isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool 579 580# if !defined(DEBUG) 581isIn _msg x ys = x `elem` ys 582isn'tIn _msg x ys = x `notElem` ys 583 584# else /* DEBUG */ 585isIn msg x ys 586 = elem100 0 x ys 587 where 588 elem100 :: Eq a => Int -> a -> [a] -> Bool 589 elem100 _ _ [] = False 590 elem100 i x (y:ys) 591 | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) 592 | otherwise = x == y || elem100 (i + 1) x ys 593 594isn'tIn msg x ys 595 = notElem100 0 x ys 596 where 597 notElem100 :: Eq a => Int -> a -> [a] -> Bool 598 notElem100 _ _ [] = True 599 notElem100 i x (y:ys) 600 | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) 601 | otherwise = x /= y && notElem100 (i + 1) x ys 602# endif /* DEBUG */ 603 604 605-- | Split a list into chunks of /n/ elements 606chunkList :: Int -> [a] -> [[a]] 607chunkList _ [] = [] 608chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs 609 610-- | Replace the last element of a list with another element. 611changeLast :: [a] -> a -> [a] 612changeLast [] _ = panic "changeLast" 613changeLast [_] x = [x] 614changeLast (x:xs) x' = x : changeLast xs x' 615 616whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () 617whenNonEmpty [] _ = pure () 618whenNonEmpty (x:xs) f = f (x :| xs) 619 620{- 621************************************************************************ 622* * 623\subsubsection{Sort utils} 624* * 625************************************************************************ 626-} 627 628minWith :: Ord b => (a -> b) -> [a] -> a 629minWith get_key xs = ASSERT( not (null xs) ) 630 head (sortWith get_key xs) 631 632nubSort :: Ord a => [a] -> [a] 633nubSort = Set.toAscList . Set.fromList 634 635-- | Remove duplicates but keep elements in order. 636-- O(n * log n) 637ordNub :: Ord a => [a] -> [a] 638ordNub xs 639 = go Set.empty xs 640 where 641 go _ [] = [] 642 go s (x:xs) 643 | Set.member x s = go s xs 644 | otherwise = x : go (Set.insert x s) xs 645 646 647{- 648************************************************************************ 649* * 650\subsection[Utils-transitive-closure]{Transitive closure} 651* * 652************************************************************************ 653 654This algorithm for transitive closure is straightforward, albeit quadratic. 655-} 656 657transitiveClosure :: (a -> [a]) -- Successor function 658 -> (a -> a -> Bool) -- Equality predicate 659 -> [a] 660 -> [a] -- The transitive closure 661 662transitiveClosure succ eq xs 663 = go [] xs 664 where 665 go done [] = done 666 go done (x:xs) | x `is_in` done = go done xs 667 | otherwise = go (x:done) (succ x ++ xs) 668 669 _ `is_in` [] = False 670 x `is_in` (y:ys) | eq x y = True 671 | otherwise = x `is_in` ys 672 673{- 674************************************************************************ 675* * 676\subsection[Utils-accum]{Accumulating} 677* * 678************************************************************************ 679 680A combination of foldl with zip. It works with equal length lists. 681-} 682 683foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc 684foldl2 _ z [] [] = z 685foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs 686foldl2 _ _ _ _ = panic "Util: foldl2" 687 688all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool 689-- True if the lists are the same length, and 690-- all corresponding elements satisfy the predicate 691all2 _ [] [] = True 692all2 p (x:xs) (y:ys) = p x y && all2 p xs ys 693all2 _ _ _ = False 694 695-- Count the number of times a predicate is true 696 697count :: (a -> Bool) -> [a] -> Int 698count p = go 0 699 where go !n [] = n 700 go !n (x:xs) | p x = go (n+1) xs 701 | otherwise = go n xs 702 703countWhile :: (a -> Bool) -> [a] -> Int 704-- Length of an /initial prefix/ of the list satsifying p 705countWhile p = go 0 706 where go !n (x:xs) | p x = go (n+1) xs 707 go !n _ = n 708 709{- 710@splitAt@, @take@, and @drop@ but with length of another 711list giving the break-off point: 712-} 713 714takeList :: [b] -> [a] -> [a] 715-- (takeList as bs) trims bs to the be same length 716-- as as, unless as is longer in which case it's a no-op 717takeList [] _ = [] 718takeList (_:xs) ls = 719 case ls of 720 [] -> [] 721 (y:ys) -> y : takeList xs ys 722 723dropList :: [b] -> [a] -> [a] 724dropList [] xs = xs 725dropList _ xs@[] = xs 726dropList (_:xs) (_:ys) = dropList xs ys 727 728 729splitAtList :: [b] -> [a] -> ([a], [a]) 730splitAtList [] xs = ([], xs) 731splitAtList _ xs@[] = (xs, xs) 732splitAtList (_:xs) (y:ys) = (y:ys', ys'') 733 where 734 (ys', ys'') = splitAtList xs ys 735 736-- drop from the end of a list 737dropTail :: Int -> [a] -> [a] 738-- Specification: dropTail n = reverse . drop n . reverse 739-- Better implemention due to Joachim Breitner 740-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html 741dropTail n xs 742 = go (drop n xs) xs 743 where 744 go (_:ys) (x:xs) = x : go ys xs 745 go _ _ = [] -- Stop when ys runs out 746 -- It'll always run out before xs does 747 748-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, 749-- but is lazy in the elements and strict in the spine. For reasonably short lists, 750-- such as path names and typical lines of text, dropWhileEndLE is generally 751-- faster than dropWhileEnd. Its advantage is magnified when the predicate is 752-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text 753-- is generally much faster than using dropWhileEnd isSpace for that purpose. 754-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse 755-- Pay attention to the short-circuit (&&)! The order of its arguments is the only 756-- difference between dropWhileEnd and dropWhileEndLE. 757dropWhileEndLE :: (a -> Bool) -> [a] -> [a] 758dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] 759 760-- | @spanEnd p l == reverse (span p (reverse l))@. The first list 761-- returns actually comes after the second list (when you look at the 762-- input list). 763spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) 764spanEnd p l = go l [] [] l 765 where go yes _rev_yes rev_no [] = (yes, reverse rev_no) 766 go yes rev_yes rev_no (x:xs) 767 | p x = go yes (x : rev_yes) rev_no xs 768 | otherwise = go xs [] (x : rev_yes ++ rev_no) xs 769 770-- | Get the last two elements in a list. Partial! 771{-# INLINE last2 #-} 772last2 :: [a] -> (a,a) 773last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) 774 where 775 partialError = panic "last2 - list length less than two" 776 777lastMaybe :: [a] -> Maybe a 778lastMaybe [] = Nothing 779lastMaybe xs = Just $ last xs 780 781-- | Split a list into its last element and the initial part of the list. 782-- @snocView xs = Just (init xs, last xs)@ for non-empty lists. 783-- @snocView xs = Nothing@ otherwise. 784-- Unless both parts of the result are guaranteed to be used 785-- prefer separate calls to @last@ + @init@. 786-- If you are guaranteed to use both, this will 787-- be more efficient. 788snocView :: [a] -> Maybe ([a],a) 789snocView [] = Nothing 790snocView xs 791 | (xs,x) <- go xs 792 = Just (xs,x) 793 where 794 go :: [a] -> ([a],a) 795 go [x] = ([],x) 796 go (x:xs) 797 | !(xs',x') <- go xs 798 = (x:xs', x') 799 go [] = error "impossible" 800 801split :: Char -> String -> [String] 802split c s = case rest of 803 [] -> [chunk] 804 _:rest -> chunk : split c rest 805 where (chunk, rest) = break (==c) s 806 807-- | Convert a word to title case by capitalising the first letter 808capitalise :: String -> String 809capitalise [] = [] 810capitalise (c:cs) = toUpper c : cs 811 812 813{- 814************************************************************************ 815* * 816\subsection[Utils-comparison]{Comparisons} 817* * 818************************************************************************ 819-} 820 821isEqual :: Ordering -> Bool 822-- Often used in (isEqual (a `compare` b)) 823isEqual GT = False 824isEqual EQ = True 825isEqual LT = False 826 827thenCmp :: Ordering -> Ordering -> Ordering 828{-# INLINE thenCmp #-} 829thenCmp EQ ordering = ordering 830thenCmp ordering _ = ordering 831 832eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool 833eqListBy _ [] [] = True 834eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys 835eqListBy _ _ _ = False 836 837eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool 838eqMaybeBy _ Nothing Nothing = True 839eqMaybeBy eq (Just x) (Just y) = eq x y 840eqMaybeBy _ _ _ = False 841 842cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering 843 -- `cmpList' uses a user-specified comparer 844 845cmpList _ [] [] = EQ 846cmpList _ [] _ = LT 847cmpList _ _ [] = GT 848cmpList cmp (a:as) (b:bs) 849 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } 850 851removeSpaces :: String -> String 852removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace 853 854-- Boolean operators lifted to Applicative 855(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool 856(<&&>) = liftA2 (&&) 857infixr 3 <&&> -- same as (&&) 858 859(<||>) :: Applicative f => f Bool -> f Bool -> f Bool 860(<||>) = liftA2 (||) 861infixr 2 <||> -- same as (||) 862 863{- 864************************************************************************ 865* * 866\subsection{Edit distance} 867* * 868************************************************************************ 869-} 870 871-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. 872-- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>. 873-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing 874-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). 875-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and 876-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation 877restrictedDamerauLevenshteinDistance :: String -> String -> Int 878restrictedDamerauLevenshteinDistance str1 str2 879 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 880 where 881 m = length str1 882 n = length str2 883 884restrictedDamerauLevenshteinDistanceWithLengths 885 :: Int -> Int -> String -> String -> Int 886restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 887 | m <= n 888 = if n <= 32 -- n must be larger so this check is sufficient 889 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 890 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 891 892 | otherwise 893 = if m <= 32 -- m must be larger so this check is sufficient 894 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 895 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 896 897restrictedDamerauLevenshteinDistance' 898 :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int 899restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 900 | [] <- str1 = n 901 | otherwise = extractAnswer $ 902 foldl' (restrictedDamerauLevenshteinDistanceWorker 903 (matchVectors str1) top_bit_mask vector_mask) 904 (0, 0, m_ones, 0, m) str2 905 where 906 m_ones@vector_mask = (2 ^ m) - 1 907 top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy 908 extractAnswer (_, _, _, _, distance) = distance 909 910restrictedDamerauLevenshteinDistanceWorker 911 :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv 912 -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) 913restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask 914 (pm, d0, vp, vn, distance) char2 915 = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ 916 seq pm' $ seq d0' $ seq vp' $ seq vn' $ 917 seq distance'' $ seq char2 $ 918 (pm', d0', vp', vn', distance'') 919 where 920 pm' = IM.findWithDefault 0 (ord char2) str1_mvs 921 922 d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) 923 .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn 924 -- No need to mask the shiftL because of the restricted range of pm 925 926 hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) 927 hn' = d0' .&. vp 928 929 hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask 930 hn'_shift = (hn' `shiftL` 1) .&. vector_mask 931 vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) 932 vn' = d0' .&. hp'_shift 933 934 distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance 935 distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' 936 937sizedComplement :: Bits bv => bv -> bv -> bv 938sizedComplement vector_mask vect = vector_mask `xor` vect 939 940matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv 941matchVectors = snd . foldl' go (0 :: Int, IM.empty) 942 where 943 go (ix, im) char = let ix' = ix + 1 944 im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im 945 in seq ix' $ seq im' $ (ix', im') 946 947{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' 948 :: Word32 -> Int -> Int -> String -> String -> Int #-} 949{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' 950 :: Integer -> Int -> Int -> String -> String -> Int #-} 951 952{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker 953 :: IM.IntMap Word32 -> Word32 -> Word32 954 -> (Word32, Word32, Word32, Word32, Int) 955 -> Char -> (Word32, Word32, Word32, Word32, Int) #-} 956{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker 957 :: IM.IntMap Integer -> Integer -> Integer 958 -> (Integer, Integer, Integer, Integer, Int) 959 -> Char -> (Integer, Integer, Integer, Integer, Int) #-} 960 961{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} 962{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} 963 964{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} 965{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} 966 967fuzzyMatch :: String -> [String] -> [String] 968fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] 969 970-- | Search for possible matches to the users input in the given list, 971-- returning a small number of ranked results 972fuzzyLookup :: String -> [(String,a)] -> [a] 973fuzzyLookup user_entered possibilites 974 = map fst $ take mAX_RESULTS $ sortBy (comparing snd) 975 [ (poss_val, distance) | (poss_str, poss_val) <- possibilites 976 , let distance = restrictedDamerauLevenshteinDistance 977 poss_str user_entered 978 , distance <= fuzzy_threshold ] 979 where 980 -- Work out an approriate match threshold: 981 -- We report a candidate if its edit distance is <= the threshold, 982 -- The threshold is set to about a quarter of the # of characters the user entered 983 -- Length Threshold 984 -- 1 0 -- Don't suggest *any* candidates 985 -- 2 1 -- for single-char identifiers 986 -- 3 1 987 -- 4 1 988 -- 5 1 989 -- 6 2 990 -- 991 fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) 992 mAX_RESULTS = 3 993 994{- 995************************************************************************ 996* * 997\subsection[Utils-pairs]{Pairs} 998* * 999************************************************************************ 1000-} 1001 1002unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] 1003unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs 1004 1005seqList :: [a] -> b -> b 1006seqList [] b = b 1007seqList (x:xs) b = x `seq` seqList xs b 1008 1009 1010{- 1011************************************************************************ 1012* * 1013 Globals and the RTS 1014* * 1015************************************************************************ 1016 1017When a plugin is loaded, it currently gets linked against a *newly 1018loaded* copy of the GHC package. This would not be a problem, except 1019that the new copy has its own mutable state that is not shared with 1020that state that has already been initialized by the original GHC 1021package. 1022 1023(Note that if the GHC executable was dynamically linked this 1024wouldn't be a problem, because we could share the GHC library it 1025links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) 1026 1027The solution is to make use of @sharedCAF@ through @sharedGlobal@ 1028for globals that are shared between multiple copies of ghc packages. 1029-} 1030 1031-- Global variables: 1032 1033global :: a -> IORef a 1034global a = unsafePerformIO (newIORef a) 1035 1036consIORef :: IORef [a] -> a -> IO () 1037consIORef var x = do 1038 atomicModifyIORef' var (\xs -> (x:xs,())) 1039 1040globalM :: IO a -> IORef a 1041globalM ma = unsafePerformIO (ma >>= newIORef) 1042 1043-- Shared global variables: 1044 1045sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a 1046sharedGlobal a get_or_set = unsafePerformIO $ 1047 newIORef a >>= flip sharedCAF get_or_set 1048 1049sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a 1050sharedGlobalM ma get_or_set = unsafePerformIO $ 1051 ma >>= newIORef >>= flip sharedCAF get_or_set 1052 1053-- Module names: 1054 1055looksLikeModuleName :: String -> Bool 1056looksLikeModuleName [] = False 1057looksLikeModuleName (c:cs) = isUpper c && go cs 1058 where go [] = True 1059 go ('.':cs) = looksLikeModuleName cs 1060 go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs 1061 1062-- Similar to 'parse' for Distribution.Package.PackageName, 1063-- but we don't want to depend on Cabal. 1064looksLikePackageName :: String -> Bool 1065looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' 1066 1067{- 1068Akin to @Prelude.words@, but acts like the Bourne shell, treating 1069quoted strings as Haskell Strings, and also parses Haskell [String] 1070syntax. 1071-} 1072 1073getCmd :: String -> Either String -- Error 1074 (String, String) -- (Cmd, Rest) 1075getCmd s = case break isSpace $ dropWhile isSpace s of 1076 ([], _) -> Left ("Couldn't find command in " ++ show s) 1077 res -> Right res 1078 1079toCmdArgs :: String -> Either String -- Error 1080 (String, [String]) -- (Cmd, Args) 1081toCmdArgs s = case getCmd s of 1082 Left err -> Left err 1083 Right (cmd, s') -> case toArgs s' of 1084 Left err -> Left err 1085 Right args -> Right (cmd, args) 1086 1087toArgs :: String -> Either String -- Error 1088 [String] -- Args 1089toArgs str 1090 = case dropWhile isSpace str of 1091 s@('[':_) -> case reads s of 1092 [(args, spaces)] 1093 | all isSpace spaces -> 1094 Right args 1095 _ -> 1096 Left ("Couldn't read " ++ show str ++ " as [String]") 1097 s -> toArgs' s 1098 where 1099 toArgs' :: String -> Either String [String] 1100 -- Remove outer quotes: 1101 -- > toArgs' "\"foo\" \"bar baz\"" 1102 -- Right ["foo", "bar baz"] 1103 -- 1104 -- Keep inner quotes: 1105 -- > toArgs' "-DFOO=\"bar baz\"" 1106 -- Right ["-DFOO=\"bar baz\""] 1107 toArgs' s = case dropWhile isSpace s of 1108 [] -> Right [] 1109 ('"' : _) -> do 1110 -- readAsString removes outer quotes 1111 (arg, rest) <- readAsString s 1112 (arg:) `fmap` toArgs' rest 1113 s' -> case break (isSpace <||> (== '"')) s' of 1114 (argPart1, s''@('"':_)) -> do 1115 (argPart2, rest) <- readAsString s'' 1116 -- show argPart2 to keep inner quotes 1117 ((argPart1 ++ show argPart2):) `fmap` toArgs' rest 1118 (arg, s'') -> (arg:) `fmap` toArgs' s'' 1119 1120 readAsString :: String -> Either String (String, String) 1121 readAsString s = case reads s of 1122 [(arg, rest)] 1123 -- rest must either be [] or start with a space 1124 | all isSpace (take 1 rest) -> 1125 Right (arg, rest) 1126 _ -> 1127 Left ("Couldn't read " ++ show s ++ " as String") 1128----------------------------------------------------------------------------- 1129-- Integers 1130 1131-- | Determine the $\log_2$ of exact powers of 2 1132exactLog2 :: Integer -> Maybe Integer 1133exactLog2 x 1134 | x <= 0 = Nothing 1135 | x > fromIntegral (maxBound :: Int32) = Nothing 1136 | x' .&. (-x') /= x' = Nothing 1137 | otherwise = Just (fromIntegral c) 1138 where 1139 x' = fromIntegral x :: Int32 1140 c = countTrailingZeros x' 1141 1142{- 1143-- ----------------------------------------------------------------------------- 1144-- Floats 1145-} 1146 1147readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" 1148readRational__ r = do 1149 (n,d,s) <- readFix r 1150 (k,t) <- readExp s 1151 return ((n%1)*10^^(k-d), t) 1152 where 1153 readFix r = do 1154 (ds,s) <- lexDecDigits r 1155 (ds',t) <- lexDotDigits s 1156 return (read (ds++ds'), length ds', t) 1157 1158 readExp (e:s) | e `elem` "eE" = readExp' s 1159 readExp s = return (0,s) 1160 1161 readExp' ('+':s) = readDec s 1162 readExp' ('-':s) = do (k,t) <- readDec s 1163 return (-k,t) 1164 readExp' s = readDec s 1165 1166 readDec s = do 1167 (ds,r) <- nonnull isDigit s 1168 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], 1169 r) 1170 1171 lexDecDigits = nonnull isDigit 1172 1173 lexDotDigits ('.':s) = return (span' isDigit s) 1174 lexDotDigits s = return ("",s) 1175 1176 nonnull p s = do (cs@(_:_),t) <- return (span' p s) 1177 return (cs,t) 1178 1179 span' _ xs@[] = (xs, xs) 1180 span' p xs@(x:xs') 1181 | x == '_' = span' p xs' -- skip "_" (#14473) 1182 | p x = let (ys,zs) = span' p xs' in (x:ys,zs) 1183 | otherwise = ([],xs) 1184 1185readRational :: String -> Rational -- NB: *does* handle a leading "-" 1186readRational top_s 1187 = case top_s of 1188 '-' : xs -> - (read_me xs) 1189 xs -> read_me xs 1190 where 1191 read_me s 1192 = case (do { (x,"") <- readRational__ s ; return x }) of 1193 [x] -> x 1194 [] -> error ("readRational: no parse:" ++ top_s) 1195 _ -> error ("readRational: ambiguous parse:" ++ top_s) 1196 1197 1198readHexRational :: String -> Rational 1199readHexRational str = 1200 case str of 1201 '-' : xs -> - (readMe xs) 1202 xs -> readMe xs 1203 where 1204 readMe as = 1205 case readHexRational__ as of 1206 Just n -> n 1207 _ -> error ("readHexRational: no parse:" ++ str) 1208 1209 1210readHexRational__ :: String -> Maybe Rational 1211readHexRational__ ('0' : x : rest) 1212 | x == 'X' || x == 'x' = 1213 do let (front,rest2) = span' isHexDigit rest 1214 guard (not (null front)) 1215 let frontNum = steps 16 0 front 1216 case rest2 of 1217 '.' : rest3 -> 1218 do let (back,rest4) = span' isHexDigit rest3 1219 guard (not (null back)) 1220 let backNum = steps 16 frontNum back 1221 exp1 = -4 * length back 1222 case rest4 of 1223 p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) 1224 _ -> return (mk backNum exp1) 1225 p : ps | isExp p -> fmap (mk frontNum) (getExp ps) 1226 _ -> Nothing 1227 1228 where 1229 isExp p = p == 'p' || p == 'P' 1230 1231 getExp ('+' : ds) = dec ds 1232 getExp ('-' : ds) = fmap negate (dec ds) 1233 getExp ds = dec ds 1234 1235 mk :: Integer -> Int -> Rational 1236 mk n e = fromInteger n * 2^^e 1237 1238 dec cs = case span' isDigit cs of 1239 (ds,"") | not (null ds) -> Just (steps 10 0 ds) 1240 _ -> Nothing 1241 1242 steps base n ds = foldl' (step base) n ds 1243 step base n d = base * n + fromIntegral (digitToInt d) 1244 1245 span' _ xs@[] = (xs, xs) 1246 span' p xs@(x:xs') 1247 | x == '_' = span' p xs' -- skip "_" (#14473) 1248 | p x = let (ys,zs) = span' p xs' in (x:ys,zs) 1249 | otherwise = ([],xs) 1250 1251readHexRational__ _ = Nothing 1252 1253----------------------------------------------------------------------------- 1254-- Verify that the 'dirname' portion of a FilePath exists. 1255-- 1256doesDirNameExist :: FilePath -> IO Bool 1257doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) 1258 1259----------------------------------------------------------------------------- 1260-- Backwards compatibility definition of getModificationTime 1261 1262getModificationUTCTime :: FilePath -> IO UTCTime 1263getModificationUTCTime = getModificationTime 1264 1265-- -------------------------------------------------------------- 1266-- check existence & modification time at the same time 1267 1268modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) 1269modificationTimeIfExists f = do 1270 (do t <- getModificationUTCTime f; return (Just t)) 1271 `catchIO` \e -> if isDoesNotExistError e 1272 then return Nothing 1273 else ioError e 1274 1275-- -------------------------------------------------------------- 1276-- atomic file writing by writing to a temporary file first (see #14533) 1277-- 1278-- This should be used in all cases where GHC writes files to disk 1279-- and uses their modification time to skip work later, 1280-- as otherwise a partially written file (e.g. due to crash or Ctrl+C) 1281-- also results in a skip. 1282 1283withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a 1284withAtomicRename targetFile f 1285 | enableAtomicRename = do 1286 -- The temp file must be on the same file system (mount) as the target file 1287 -- to result in an atomic move on most platforms. 1288 -- The standard way to ensure that is to place it into the same directory. 1289 -- This can still be fooled when somebody mounts a different file system 1290 -- at just the right time, but that is not a case we aim to cover here. 1291 let temp = targetFile <.> "tmp" 1292 res <- f temp 1293 liftIO $ renameFile temp targetFile 1294 return res 1295 1296 | otherwise = f targetFile 1297 where 1298 -- As described in #16450, enabling this causes spurious build failures due 1299 -- to apparently missing files. 1300 enableAtomicRename :: Bool 1301#if defined(mingw32_BUILD_OS) 1302 enableAtomicRename = False 1303#else 1304 enableAtomicRename = True 1305#endif 1306 1307-- -------------------------------------------------------------- 1308-- split a string at the last character where 'pred' is True, 1309-- returning a pair of strings. The first component holds the string 1310-- up (but not including) the last character for which 'pred' returned 1311-- True, the second whatever comes after (but also not including the 1312-- last character). 1313-- 1314-- If 'pred' returns False for all characters in the string, the original 1315-- string is returned in the first component (and the second one is just 1316-- empty). 1317splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) 1318splitLongestPrefix str pred 1319 | null r_pre = (str, []) 1320 | otherwise = (reverse (tail r_pre), reverse r_suf) 1321 -- 'tail' drops the char satisfying 'pred' 1322 where (r_suf, r_pre) = break pred (reverse str) 1323 1324escapeSpaces :: String -> String 1325escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" 1326 1327type Suffix = String 1328 1329-------------------------------------------------------------- 1330-- * Search path 1331-------------------------------------------------------------- 1332 1333data Direction = Forwards | Backwards 1334 1335reslash :: Direction -> FilePath -> FilePath 1336reslash d = f 1337 where f ('/' : xs) = slash : f xs 1338 f ('\\' : xs) = slash : f xs 1339 f (x : xs) = x : f xs 1340 f "" = "" 1341 slash = case d of 1342 Forwards -> '/' 1343 Backwards -> '\\' 1344 1345makeRelativeTo :: FilePath -> FilePath -> FilePath 1346this `makeRelativeTo` that = directory </> thisFilename 1347 where (thisDirectory, thisFilename) = splitFileName this 1348 thatDirectory = dropFileName that 1349 directory = joinPath $ f (splitPath thisDirectory) 1350 (splitPath thatDirectory) 1351 1352 f (x : xs) (y : ys) 1353 | x == y = f xs ys 1354 f xs ys = replicate (length ys) ".." ++ xs 1355 1356{- 1357************************************************************************ 1358* * 1359\subsection[Utils-Data]{Utils for defining Data instances} 1360* * 1361************************************************************************ 1362 1363These functions helps us to define Data instances for abstract types. 1364-} 1365 1366abstractConstr :: String -> Constr 1367abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix 1368 1369abstractDataType :: String -> DataType 1370abstractDataType n = mkDataType n [abstractConstr n] 1371 1372{- 1373************************************************************************ 1374* * 1375\subsection[Utils-C]{Utils for printing C code} 1376* * 1377************************************************************************ 1378-} 1379 1380charToC :: Word8 -> String 1381charToC w = 1382 case chr (fromIntegral w) of 1383 '\"' -> "\\\"" 1384 '\'' -> "\\\'" 1385 '\\' -> "\\\\" 1386 c | c >= ' ' && c <= '~' -> [c] 1387 | otherwise -> ['\\', 1388 chr (ord '0' + ord c `div` 64), 1389 chr (ord '0' + ord c `div` 8 `mod` 8), 1390 chr (ord '0' + ord c `mod` 8)] 1391 1392{- 1393************************************************************************ 1394* * 1395\subsection[Utils-Hashing]{Utils for hashing} 1396* * 1397************************************************************************ 1398-} 1399 1400-- | A sample hash function for Strings. We keep multiplying by the 1401-- golden ratio and adding. The implementation is: 1402-- 1403-- > hashString = foldl' f golden 1404-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m 1405-- > magic = 0xdeadbeef 1406-- 1407-- Where hashInt32 works just as hashInt shown above. 1408-- 1409-- Knuth argues that repeated multiplication by the golden ratio 1410-- will minimize gaps in the hash space, and thus it's a good choice 1411-- for combining together multiple keys to form one. 1412-- 1413-- Here we know that individual characters c are often small, and this 1414-- produces frequent collisions if we use ord c alone. A 1415-- particular problem are the shorter low ASCII and ISO-8859-1 1416-- character strings. We pre-multiply by a magic twiddle factor to 1417-- obtain a good distribution. In fact, given the following test: 1418-- 1419-- > testp :: Int32 -> Int 1420-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls 1421-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] 1422-- > hs = foldl' f golden 1423-- > f m c = fromIntegral (ord c) * k + hashInt32 m 1424-- > n = 100000 1425-- 1426-- We discover that testp magic = 0. 1427hashString :: String -> Int32 1428hashString = foldl' f golden 1429 where f m c = fromIntegral (ord c) * magic + hashInt32 m 1430 magic = fromIntegral (0xdeadbeef :: Word32) 1431 1432golden :: Int32 1433golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 1434-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 1435-- but that has bad mulHi properties (even adding 2^32 to get its inverse) 1436-- Whereas the above works well and contains no hash duplications for 1437-- [-32767..65536] 1438 1439-- | A sample (and useful) hash function for Int32, 1440-- implemented by extracting the uppermost 32 bits of the 64-bit 1441-- result of multiplying by a 33-bit constant. The constant is from 1442-- Knuth, derived from the golden ratio: 1443-- 1444-- > golden = round ((sqrt 5 - 1) * 2^32) 1445-- 1446-- We get good key uniqueness on small inputs 1447-- (a problem with previous versions): 1448-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 1449-- 1450hashInt32 :: Int32 -> Int32 1451hashInt32 x = mulHi x golden + x 1452 1453-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply 1454mulHi :: Int32 -> Int32 -> Int32 1455mulHi a b = fromIntegral (r `shiftR` 32) 1456 where r :: Int64 1457 r = fromIntegral a * fromIntegral b 1458 1459-- | A call stack constraint, but only when 'isDebugOn'. 1460#if defined(DEBUG) 1461type HasDebugCallStack = HasCallStack 1462#else 1463type HasDebugCallStack = (() :: Constraint) 1464#endif 1465 1466data OverridingBool 1467 = Auto 1468 | Always 1469 | Never 1470 deriving Show 1471 1472overrideWith :: Bool -> OverridingBool -> Bool 1473overrideWith b Auto = b 1474overrideWith _ Always = True 1475overrideWith _ Never = False 1476