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