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