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