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