4b8c47a2cfb9e30e000744ae556228c63273894b
[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, neLength, compareLength, leLength, ltLength,
39
40 isSingleton, only, singleton,
41 notNull, snocView,
42
43 isIn, isn'tIn,
44
45 chunkList,
46
47 changeLast,
48
49 -- * Tuples
50 fstOf3, sndOf3, thdOf3,
51 firstM, first3M, secondM,
52 fst3, snd3, third3,
53 uncurry3,
54 liftFst, liftSnd,
55
56 -- * List operations controlled by another list
57 takeList, dropList, splitAtList, split,
58 dropTail, capitalise,
59
60 -- * For loop
61 nTimes,
62
63 -- * Sorting
64 sortWith, minWith, nubSort, ordNub,
65
66 -- * Comparisons
67 isEqual, eqListBy, eqMaybeBy,
68 thenCmp, cmpList,
69 removeSpaces,
70 (<&&>), (<||>),
71
72 -- * Edit distance
73 fuzzyMatch, fuzzyLookup,
74
75 -- * Transitive closures
76 transitiveClosure,
77
78 -- * Strictness
79 seqList,
80
81 -- * Module names
82 looksLikeModuleName,
83 looksLikePackageName,
84
85 -- * Argument processing
86 getCmd, toCmdArgs, toArgs,
87
88 -- * Integers
89 exactLog2,
90
91 -- * Floating point
92 readRational,
93 readHexRational,
94
95 -- * read helpers
96 maybeRead, maybeReadFuzzy,
97
98 -- * IO-ish utilities
99 doesDirNameExist,
100 getModificationUTCTime,
101 modificationTimeIfExists,
102 withAtomicRename,
103
104 global, consIORef, globalM,
105 sharedGlobal, sharedGlobalM,
106
107 -- * Filenames and paths
108 Suffix,
109 splitLongestPrefix,
110 escapeSpaces,
111 Direction(..), reslash,
112 makeRelativeTo,
113
114 -- * Utils for defining Data instances
115 abstractConstr, abstractDataType, mkNoRepType,
116
117 -- * Utils for printing C code
118 charToC,
119
120 -- * Hashing
121 hashString,
122
123 -- * Call stacks
124 HasCallStack,
125 HasDebugCallStack,
126
127 -- * Utils for flags
128 OverridingBool(..),
129 overrideWith,
130 ) where
131
132 #include "HsVersions.h"
133
134 import GhcPrelude
135
136 import Exception
137 import 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 neLength :: [a] -> [b] -> Bool
539 -- ^ True if length xs /= length ys
540 neLength [] [] = False
541 neLength (_:xs) (_:ys) = neLength xs ys
542 neLength _ _ = True
543
544 compareLength :: [a] -> [b] -> Ordering
545 compareLength [] [] = EQ
546 compareLength (_:xs) (_:ys) = compareLength xs ys
547 compareLength [] _ = LT
548 compareLength _ [] = GT
549
550 leLength :: [a] -> [b] -> Bool
551 -- ^ True if length xs <= length ys
552 leLength xs ys = case compareLength xs ys of
553 LT -> True
554 EQ -> True
555 GT -> False
556
557 ltLength :: [a] -> [b] -> Bool
558 -- ^ True if length xs < length ys
559 ltLength xs ys = case compareLength xs ys of
560 LT -> True
561 EQ -> False
562 GT -> False
563
564 ----------------------------
565 singleton :: a -> [a]
566 singleton x = [x]
567
568 isSingleton :: [a] -> Bool
569 isSingleton [_] = True
570 isSingleton _ = False
571
572 notNull :: [a] -> Bool
573 notNull [] = False
574 notNull _ = True
575
576 only :: [a] -> a
577 #if defined(DEBUG)
578 only [a] = a
579 #else
580 only (a:_) = a
581 #endif
582 only _ = panic "Util: only"
583
584 -- Debugging/specialising versions of \tr{elem} and \tr{notElem}
585
586 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
587
588 # ifndef DEBUG
589 isIn _msg x ys = x `elem` ys
590 isn'tIn _msg x ys = x `notElem` ys
591
592 # else /* DEBUG */
593 isIn msg x ys
594 = elem100 0 x ys
595 where
596 elem100 :: Eq a => Int -> a -> [a] -> Bool
597 elem100 _ _ [] = False
598 elem100 i x (y:ys)
599 | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
600 | otherwise = x == y || elem100 (i + 1) x ys
601
602 isn'tIn msg x ys
603 = notElem100 0 x ys
604 where
605 notElem100 :: Eq a => Int -> a -> [a] -> Bool
606 notElem100 _ _ [] = True
607 notElem100 i x (y:ys)
608 | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
609 | otherwise = x /= y && notElem100 (i + 1) x ys
610 # endif /* DEBUG */
611
612
613 -- | Split a list into chunks of /n/ elements
614 chunkList :: Int -> [a] -> [[a]]
615 chunkList _ [] = []
616 chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs
617
618 -- | Replace the last element of a list with another element.
619 changeLast :: [a] -> a -> [a]
620 changeLast [] _ = panic "changeLast"
621 changeLast [_] x = [x]
622 changeLast (x:xs) x' = x : changeLast xs x'
623
624 {-
625 ************************************************************************
626 * *
627 \subsubsection{Sort utils}
628 * *
629 ************************************************************************
630 -}
631
632 minWith :: Ord b => (a -> b) -> [a] -> a
633 minWith get_key xs = ASSERT( not (null xs) )
634 head (sortWith get_key xs)
635
636 nubSort :: Ord a => [a] -> [a]
637 nubSort = Set.toAscList . Set.fromList
638
639 -- | Remove duplicates but keep elements in order.
640 -- O(n * log n)
641 ordNub :: Ord a => [a] -> [a]
642 ordNub xs
643 = go Set.empty xs
644 where
645 go _ [] = []
646 go s (x:xs)
647 | Set.member x s = go s xs
648 | otherwise = x : go (Set.insert x s) xs
649
650
651 {-
652 ************************************************************************
653 * *
654 \subsection[Utils-transitive-closure]{Transitive closure}
655 * *
656 ************************************************************************
657
658 This algorithm for transitive closure is straightforward, albeit quadratic.
659 -}
660
661 transitiveClosure :: (a -> [a]) -- Successor function
662 -> (a -> a -> Bool) -- Equality predicate
663 -> [a]
664 -> [a] -- The transitive closure
665
666 transitiveClosure succ eq xs
667 = go [] xs
668 where
669 go done [] = done
670 go done (x:xs) | x `is_in` done = go done xs
671 | otherwise = go (x:done) (succ x ++ xs)
672
673 _ `is_in` [] = False
674 x `is_in` (y:ys) | eq x y = True
675 | otherwise = x `is_in` ys
676
677 {-
678 ************************************************************************
679 * *
680 \subsection[Utils-accum]{Accumulating}
681 * *
682 ************************************************************************
683
684 A combination of foldl with zip. It works with equal length lists.
685 -}
686
687 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
688 foldl2 _ z [] [] = z
689 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
690 foldl2 _ _ _ _ = panic "Util: foldl2"
691
692 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
693 -- True if the lists are the same length, and
694 -- all corresponding elements satisfy the predicate
695 all2 _ [] [] = True
696 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
697 all2 _ _ _ = False
698
699 -- Count the number of times a predicate is true
700
701 count :: (a -> Bool) -> [a] -> Int
702 count p = go 0
703 where go !n [] = n
704 go !n (x:xs) | p x = go (n+1) xs
705 | otherwise = go n xs
706
707 countWhile :: (a -> Bool) -> [a] -> Int
708 -- Length of an /initial prefix/ of the list satsifying p
709 countWhile p = go 0
710 where go !n (x:xs) | p x = go (n+1) xs
711 go !n _ = n
712
713 {-
714 @splitAt@, @take@, and @drop@ but with length of another
715 list giving the break-off point:
716 -}
717
718 takeList :: [b] -> [a] -> [a]
719 -- (takeList as bs) trims bs to the be same length
720 -- as as, unless as is longer in which case it's a no-op
721 takeList [] _ = []
722 takeList (_:xs) ls =
723 case ls of
724 [] -> []
725 (y:ys) -> y : takeList xs ys
726
727 dropList :: [b] -> [a] -> [a]
728 dropList [] xs = xs
729 dropList _ xs@[] = xs
730 dropList (_:xs) (_:ys) = dropList xs ys
731
732
733 splitAtList :: [b] -> [a] -> ([a], [a])
734 splitAtList [] xs = ([], xs)
735 splitAtList _ xs@[] = (xs, xs)
736 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
737 where
738 (ys', ys'') = splitAtList xs ys
739
740 -- drop from the end of a list
741 dropTail :: Int -> [a] -> [a]
742 -- Specification: dropTail n = reverse . drop n . reverse
743 -- Better implemention due to Joachim Breitner
744 -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html
745 dropTail n xs
746 = go (drop n xs) xs
747 where
748 go (_:ys) (x:xs) = x : go ys xs
749 go _ _ = [] -- Stop when ys runs out
750 -- It'll always run out before xs does
751
752 -- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd,
753 -- but is lazy in the elements and strict in the spine. For reasonably short lists,
754 -- such as path names and typical lines of text, dropWhileEndLE is generally
755 -- faster than dropWhileEnd. Its advantage is magnified when the predicate is
756 -- expensive--using dropWhileEndLE isSpace to strip the space off a line of text
757 -- is generally much faster than using dropWhileEnd isSpace for that purpose.
758 -- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse
759 -- Pay attention to the short-circuit (&&)! The order of its arguments is the only
760 -- difference between dropWhileEnd and dropWhileEndLE.
761 dropWhileEndLE :: (a -> Bool) -> [a] -> [a]
762 dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []
763
764 -- | @spanEnd p l == reverse (span p (reverse l))@. The first list
765 -- returns actually comes after the second list (when you look at the
766 -- input list).
767 spanEnd :: (a -> Bool) -> [a] -> ([a], [a])
768 spanEnd p l = go l [] [] l
769 where go yes _rev_yes rev_no [] = (yes, reverse rev_no)
770 go yes rev_yes rev_no (x:xs)
771 | p x = go yes (x : rev_yes) rev_no xs
772 | otherwise = go xs [] (x : rev_yes ++ rev_no) xs
773
774 -- | Get the last two elements in a list. Partial!
775 {-# INLINE last2 #-}
776 last2 :: [a] -> (a,a)
777 last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError)
778 where
779 partialError = panic "last2 - list length less than two"
780
781 lastMaybe :: [a] -> Maybe a
782 lastMaybe [] = Nothing
783 lastMaybe xs = Just $ last xs
784
785 -- | Split a list into its last element and the initial part of the list.
786 -- @snocView xs = Just (init xs, last xs)@ for non-empty lists.
787 -- @snocView xs = Nothing@ otherwise.
788 -- Unless both parts of the result are guaranteed to be used
789 -- prefer separate calls to @last@ + @init@.
790 -- If you are guaranteed to use both, this will
791 -- be more efficient.
792 snocView :: [a] -> Maybe ([a],a)
793 snocView [] = Nothing
794 snocView xs
795 | (xs,x) <- go xs
796 = Just (xs,x)
797 where
798 go :: [a] -> ([a],a)
799 go [x] = ([],x)
800 go (x:xs)
801 | !(xs',x') <- go xs
802 = (x:xs', x')
803 go [] = error "impossible"
804
805 split :: Char -> String -> [String]
806 split c s = case rest of
807 [] -> [chunk]
808 _:rest -> chunk : split c rest
809 where (chunk, rest) = break (==c) s
810
811 -- | Convert a word to title case by capitalising the first letter
812 capitalise :: String -> String
813 capitalise [] = []
814 capitalise (c:cs) = toUpper c : cs
815
816
817 {-
818 ************************************************************************
819 * *
820 \subsection[Utils-comparison]{Comparisons}
821 * *
822 ************************************************************************
823 -}
824
825 isEqual :: Ordering -> Bool
826 -- Often used in (isEqual (a `compare` b))
827 isEqual GT = False
828 isEqual EQ = True
829 isEqual LT = False
830
831 thenCmp :: Ordering -> Ordering -> Ordering
832 {-# INLINE thenCmp #-}
833 thenCmp EQ ordering = ordering
834 thenCmp ordering _ = ordering
835
836 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
837 eqListBy _ [] [] = True
838 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
839 eqListBy _ _ _ = False
840
841 eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool
842 eqMaybeBy _ Nothing Nothing = True
843 eqMaybeBy eq (Just x) (Just y) = eq x y
844 eqMaybeBy _ _ _ = False
845
846 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
847 -- `cmpList' uses a user-specified comparer
848
849 cmpList _ [] [] = EQ
850 cmpList _ [] _ = LT
851 cmpList _ _ [] = GT
852 cmpList cmp (a:as) (b:bs)
853 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
854
855 removeSpaces :: String -> String
856 removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace
857
858 -- Boolean operators lifted to Applicative
859 (<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
860 (<&&>) = liftA2 (&&)
861 infixr 3 <&&> -- same as (&&)
862
863 (<||>) :: Applicative f => f Bool -> f Bool -> f Bool
864 (<||>) = liftA2 (||)
865 infixr 2 <||> -- same as (||)
866
867 {-
868 ************************************************************************
869 * *
870 \subsection{Edit distance}
871 * *
872 ************************************************************************
873 -}
874
875 -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings.
876 -- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.
877 -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing
878 -- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).
879 -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and
880 -- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation
881 restrictedDamerauLevenshteinDistance :: String -> String -> Int
882 restrictedDamerauLevenshteinDistance str1 str2
883 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
884 where
885 m = length str1
886 n = length str2
887
888 restrictedDamerauLevenshteinDistanceWithLengths
889 :: Int -> Int -> String -> String -> Int
890 restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
891 | m <= n
892 = if n <= 32 -- n must be larger so this check is sufficient
893 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2
894 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2
895
896 | otherwise
897 = if m <= 32 -- m must be larger so this check is sufficient
898 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1
899 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1
900
901 restrictedDamerauLevenshteinDistance'
902 :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int
903 restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
904 | [] <- str1 = n
905 | otherwise = extractAnswer $
906 foldl' (restrictedDamerauLevenshteinDistanceWorker
907 (matchVectors str1) top_bit_mask vector_mask)
908 (0, 0, m_ones, 0, m) str2
909 where
910 m_ones@vector_mask = (2 ^ m) - 1
911 top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy
912 extractAnswer (_, _, _, _, distance) = distance
913
914 restrictedDamerauLevenshteinDistanceWorker
915 :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv
916 -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
917 restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask
918 (pm, d0, vp, vn, distance) char2
919 = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $
920 seq pm' $ seq d0' $ seq vp' $ seq vn' $
921 seq distance'' $ seq char2 $
922 (pm', d0', vp', vn', distance'')
923 where
924 pm' = IM.findWithDefault 0 (ord char2) str1_mvs
925
926 d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm)
927 .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn
928 -- No need to mask the shiftL because of the restricted range of pm
929
930 hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)
931 hn' = d0' .&. vp
932
933 hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask
934 hn'_shift = (hn' `shiftL` 1) .&. vector_mask
935 vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)
936 vn' = d0' .&. hp'_shift
937
938 distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance
939 distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
940
941 sizedComplement :: Bits bv => bv -> bv -> bv
942 sizedComplement vector_mask vect = vector_mask `xor` vect
943
944 matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv
945 matchVectors = snd . foldl' go (0 :: Int, IM.empty)
946 where
947 go (ix, im) char = let ix' = ix + 1
948 im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im
949 in seq ix' $ seq im' $ (ix', im')
950
951 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
952 :: Word32 -> Int -> Int -> String -> String -> Int #-}
953 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
954 :: Integer -> Int -> Int -> String -> String -> Int #-}
955
956 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
957 :: IM.IntMap Word32 -> Word32 -> Word32
958 -> (Word32, Word32, Word32, Word32, Int)
959 -> Char -> (Word32, Word32, Word32, Word32, Int) #-}
960 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
961 :: IM.IntMap Integer -> Integer -> Integer
962 -> (Integer, Integer, Integer, Integer, Int)
963 -> Char -> (Integer, Integer, Integer, Integer, Int) #-}
964
965 {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}
966 {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}
967
968 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}
969 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}
970
971 fuzzyMatch :: String -> [String] -> [String]
972 fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals]
973
974 -- | Search for possible matches to the users input in the given list,
975 -- returning a small number of ranked results
976 fuzzyLookup :: String -> [(String,a)] -> [a]
977 fuzzyLookup user_entered possibilites
978 = map fst $ take mAX_RESULTS $ sortBy (comparing snd)
979 [ (poss_val, distance) | (poss_str, poss_val) <- possibilites
980 , let distance = restrictedDamerauLevenshteinDistance
981 poss_str user_entered
982 , distance <= fuzzy_threshold ]
983 where
984 -- Work out an approriate match threshold:
985 -- We report a candidate if its edit distance is <= the threshold,
986 -- The threshold is set to about a quarter of the # of characters the user entered
987 -- Length Threshold
988 -- 1 0 -- Don't suggest *any* candidates
989 -- 2 1 -- for single-char identifiers
990 -- 3 1
991 -- 4 1
992 -- 5 1
993 -- 6 2
994 --
995 fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational)
996 mAX_RESULTS = 3
997
998 {-
999 ************************************************************************
1000 * *
1001 \subsection[Utils-pairs]{Pairs}
1002 * *
1003 ************************************************************************
1004 -}
1005
1006 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
1007 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
1008
1009 seqList :: [a] -> b -> b
1010 seqList [] b = b
1011 seqList (x:xs) b = x `seq` seqList xs b
1012
1013
1014 {-
1015 ************************************************************************
1016 * *
1017 Globals and the RTS
1018 * *
1019 ************************************************************************
1020
1021 When a plugin is loaded, it currently gets linked against a *newly
1022 loaded* copy of the GHC package. This would not be a problem, except
1023 that the new copy has its own mutable state that is not shared with
1024 that state that has already been initialized by the original GHC
1025 package.
1026
1027 (Note that if the GHC executable was dynamically linked this
1028 wouldn't be a problem, because we could share the GHC library it
1029 links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.)
1030
1031 The solution is to make use of @sharedCAF@ through @sharedGlobal@
1032 for globals that are shared between multiple copies of ghc packages.
1033 -}
1034
1035 -- Global variables:
1036
1037 global :: a -> IORef a
1038 global a = unsafePerformIO (newIORef a)
1039
1040 consIORef :: IORef [a] -> a -> IO ()
1041 consIORef var x = do
1042 atomicModifyIORef' var (\xs -> (x:xs,()))
1043
1044 globalM :: IO a -> IORef a
1045 globalM ma = unsafePerformIO (ma >>= newIORef)
1046
1047 -- Shared global variables:
1048
1049 sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a
1050 sharedGlobal a get_or_set = unsafePerformIO $
1051 newIORef a >>= flip sharedCAF get_or_set
1052
1053 sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a
1054 sharedGlobalM ma get_or_set = unsafePerformIO $
1055 ma >>= newIORef >>= flip sharedCAF get_or_set
1056
1057 -- Module names:
1058
1059 looksLikeModuleName :: String -> Bool
1060 looksLikeModuleName [] = False
1061 looksLikeModuleName (c:cs) = isUpper c && go cs
1062 where go [] = True
1063 go ('.':cs) = looksLikeModuleName cs
1064 go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs
1065
1066 -- Similar to 'parse' for Distribution.Package.PackageName,
1067 -- but we don't want to depend on Cabal.
1068 looksLikePackageName :: String -> Bool
1069 looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-'
1070
1071 {-
1072 Akin to @Prelude.words@, but acts like the Bourne shell, treating
1073 quoted strings as Haskell Strings, and also parses Haskell [String]
1074 syntax.
1075 -}
1076
1077 getCmd :: String -> Either String -- Error
1078 (String, String) -- (Cmd, Rest)
1079 getCmd s = case break isSpace $ dropWhile isSpace s of
1080 ([], _) -> Left ("Couldn't find command in " ++ show s)
1081 res -> Right res
1082
1083 toCmdArgs :: String -> Either String -- Error
1084 (String, [String]) -- (Cmd, Args)
1085 toCmdArgs s = case getCmd s of
1086 Left err -> Left err
1087 Right (cmd, s') -> case toArgs s' of
1088 Left err -> Left err
1089 Right args -> Right (cmd, args)
1090
1091 toArgs :: String -> Either String -- Error
1092 [String] -- Args
1093 toArgs str
1094 = case dropWhile isSpace str of
1095 s@('[':_) -> case reads s of
1096 [(args, spaces)]
1097 | all isSpace spaces ->
1098 Right args
1099 _ ->
1100 Left ("Couldn't read " ++ show str ++ " as [String]")
1101 s -> toArgs' s
1102 where
1103 toArgs' :: String -> Either String [String]
1104 -- Remove outer quotes:
1105 -- > toArgs' "\"foo\" \"bar baz\""
1106 -- Right ["foo", "bar baz"]
1107 --
1108 -- Keep inner quotes:
1109 -- > toArgs' "-DFOO=\"bar baz\""
1110 -- Right ["-DFOO=\"bar baz\""]
1111 toArgs' s = case dropWhile isSpace s of
1112 [] -> Right []
1113 ('"' : _) -> do
1114 -- readAsString removes outer quotes
1115 (arg, rest) <- readAsString s
1116 (arg:) `fmap` toArgs' rest
1117 s' -> case break (isSpace <||> (== '"')) s' of
1118 (argPart1, s''@('"':_)) -> do
1119 (argPart2, rest) <- readAsString s''
1120 -- show argPart2 to keep inner quotes
1121 ((argPart1 ++ show argPart2):) `fmap` toArgs' rest
1122 (arg, s'') -> (arg:) `fmap` toArgs' s''
1123
1124 readAsString :: String -> Either String (String, String)
1125 readAsString s = case reads s of
1126 [(arg, rest)]
1127 -- rest must either be [] or start with a space
1128 | all isSpace (take 1 rest) ->
1129 Right (arg, rest)
1130 _ ->
1131 Left ("Couldn't read " ++ show s ++ " as String")
1132 -----------------------------------------------------------------------------
1133 -- Integers
1134
1135 -- This algorithm for determining the $\log_2$ of exact powers of 2 comes
1136 -- from GCC. It requires bit manipulation primitives, and we use GHC
1137 -- extensions. Tough.
1138
1139 exactLog2 :: Integer -> Maybe Integer
1140 exactLog2 x
1141 = if (x <= 0 || x >= 2147483648) then
1142 Nothing
1143 else
1144 if (x .&. (-x)) /= x then
1145 Nothing
1146 else
1147 Just (pow2 x)
1148 where
1149 pow2 x | x == 1 = 0
1150 | otherwise = 1 + pow2 (x `shiftR` 1)
1151
1152 {-
1153 -- -----------------------------------------------------------------------------
1154 -- Floats
1155 -}
1156
1157 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
1158 readRational__ r = do
1159 (n,d,s) <- readFix r
1160 (k,t) <- readExp s
1161 return ((n%1)*10^^(k-d), t)
1162 where
1163 readFix r = do
1164 (ds,s) <- lexDecDigits r
1165 (ds',t) <- lexDotDigits s
1166 return (read (ds++ds'), length ds', t)
1167
1168 readExp (e:s) | e `elem` "eE" = readExp' s
1169 readExp s = return (0,s)
1170
1171 readExp' ('+':s) = readDec s
1172 readExp' ('-':s) = do (k,t) <- readDec s
1173 return (-k,t)
1174 readExp' s = readDec s
1175
1176 readDec s = do
1177 (ds,r) <- nonnull isDigit s
1178 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
1179 r)
1180
1181 lexDecDigits = nonnull isDigit
1182
1183 lexDotDigits ('.':s) = return (span' isDigit s)
1184 lexDotDigits s = return ("",s)
1185
1186 nonnull p s = do (cs@(_:_),t) <- return (span' p s)
1187 return (cs,t)
1188
1189 span' _ xs@[] = (xs, xs)
1190 span' p xs@(x:xs')
1191 | x == '_' = span' p xs' -- skip "_" (#14473)
1192 | p x = let (ys,zs) = span' p xs' in (x:ys,zs)
1193 | otherwise = ([],xs)
1194
1195 readRational :: String -> Rational -- NB: *does* handle a leading "-"
1196 readRational top_s
1197 = case top_s of
1198 '-' : xs -> - (read_me xs)
1199 xs -> read_me xs
1200 where
1201 read_me s
1202 = case (do { (x,"") <- readRational__ s ; return x }) of
1203 [x] -> x
1204 [] -> error ("readRational: no parse:" ++ top_s)
1205 _ -> error ("readRational: ambiguous parse:" ++ top_s)
1206
1207
1208 readHexRational :: String -> Rational
1209 readHexRational str =
1210 case str of
1211 '-' : xs -> - (readMe xs)
1212 xs -> readMe xs
1213 where
1214 readMe as =
1215 case readHexRational__ as of
1216 Just n -> n
1217 _ -> error ("readHexRational: no parse:" ++ str)
1218
1219
1220 readHexRational__ :: String -> Maybe Rational
1221 readHexRational__ ('0' : x : rest)
1222 | x == 'X' || x == 'x' =
1223 do let (front,rest2) = span' isHexDigit rest
1224 guard (not (null front))
1225 let frontNum = steps 16 0 front
1226 case rest2 of
1227 '.' : rest3 ->
1228 do let (back,rest4) = span' isHexDigit rest3
1229 guard (not (null back))
1230 let backNum = steps 16 frontNum back
1231 exp1 = -4 * length back
1232 case rest4 of
1233 p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps)
1234 _ -> return (mk backNum exp1)
1235 p : ps | isExp p -> fmap (mk frontNum) (getExp ps)
1236 _ -> Nothing
1237
1238 where
1239 isExp p = p == 'p' || p == 'P'
1240
1241 getExp ('+' : ds) = dec ds
1242 getExp ('-' : ds) = fmap negate (dec ds)
1243 getExp ds = dec ds
1244
1245 mk :: Integer -> Int -> Rational
1246 mk n e = fromInteger n * 2^^e
1247
1248 dec cs = case span' isDigit cs of
1249 (ds,"") | not (null ds) -> Just (steps 10 0 ds)
1250 _ -> Nothing
1251
1252 steps base n ds = foldl' (step base) n ds
1253 step base n d = base * n + fromIntegral (digitToInt d)
1254
1255 span' _ xs@[] = (xs, xs)
1256 span' p xs@(x:xs')
1257 | x == '_' = span' p xs' -- skip "_" (#14473)
1258 | p x = let (ys,zs) = span' p xs' in (x:ys,zs)
1259 | otherwise = ([],xs)
1260
1261 readHexRational__ _ = Nothing
1262
1263
1264
1265
1266 -----------------------------------------------------------------------------
1267 -- read helpers
1268
1269 maybeRead :: Read a => String -> Maybe a
1270 maybeRead str = case reads str of
1271 [(x, "")] -> Just x
1272 _ -> Nothing
1273
1274 maybeReadFuzzy :: Read a => String -> Maybe a
1275 maybeReadFuzzy str = case reads str of
1276 [(x, s)]
1277 | all isSpace s ->
1278 Just x
1279 _ ->
1280 Nothing
1281
1282 -----------------------------------------------------------------------------
1283 -- Verify that the 'dirname' portion of a FilePath exists.
1284 --
1285 doesDirNameExist :: FilePath -> IO Bool
1286 doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath)
1287
1288 -----------------------------------------------------------------------------
1289 -- Backwards compatibility definition of getModificationTime
1290
1291 getModificationUTCTime :: FilePath -> IO UTCTime
1292 getModificationUTCTime = getModificationTime
1293
1294 -- --------------------------------------------------------------
1295 -- check existence & modification time at the same time
1296
1297 modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)
1298 modificationTimeIfExists f = do
1299 (do t <- getModificationUTCTime f; return (Just t))
1300 `catchIO` \e -> if isDoesNotExistError e
1301 then return Nothing
1302 else ioError e
1303
1304 -- --------------------------------------------------------------
1305 -- atomic file writing by writing to a temporary file first (see #14533)
1306 --
1307 -- This should be used in all cases where GHC writes files to disk
1308 -- and uses their modification time to skip work later,
1309 -- as otherwise a partially written file (e.g. due to crash or Ctrl+C)
1310 -- also results in a skip.
1311
1312 withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a
1313 withAtomicRename targetFile f
1314 | enableAtomicRename = do
1315 -- The temp file must be on the same file system (mount) as the target file
1316 -- to result in an atomic move on most platforms.
1317 -- The standard way to ensure that is to place it into the same directory.
1318 -- This can still be fooled when somebody mounts a different file system
1319 -- at just the right time, but that is not a case we aim to cover here.
1320 let temp = targetFile <.> "tmp"
1321 res <- f temp
1322 liftIO $ renameFile temp targetFile
1323 return res
1324
1325 | otherwise = f targetFile
1326 where
1327 -- As described in #16450, enabling this causes spurious build failures due
1328 -- to apparently missing files.
1329 enableAtomicRename :: Bool
1330 #if defined(mingw32_BUILD_OS)
1331 enableAtomicRename = False
1332 #else
1333 enableAtomicRename = True
1334 #endif
1335
1336 -- --------------------------------------------------------------
1337 -- split a string at the last character where 'pred' is True,
1338 -- returning a pair of strings. The first component holds the string
1339 -- up (but not including) the last character for which 'pred' returned
1340 -- True, the second whatever comes after (but also not including the
1341 -- last character).
1342 --
1343 -- If 'pred' returns False for all characters in the string, the original
1344 -- string is returned in the first component (and the second one is just
1345 -- empty).
1346 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
1347 splitLongestPrefix str pred
1348 | null r_pre = (str, [])
1349 | otherwise = (reverse (tail r_pre), reverse r_suf)
1350 -- 'tail' drops the char satisfying 'pred'
1351 where (r_suf, r_pre) = break pred (reverse str)
1352
1353 escapeSpaces :: String -> String
1354 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
1355
1356 type Suffix = String
1357
1358 --------------------------------------------------------------
1359 -- * Search path
1360 --------------------------------------------------------------
1361
1362 data Direction = Forwards | Backwards
1363
1364 reslash :: Direction -> FilePath -> FilePath
1365 reslash d = f
1366 where f ('/' : xs) = slash : f xs
1367 f ('\\' : xs) = slash : f xs
1368 f (x : xs) = x : f xs
1369 f "" = ""
1370 slash = case d of
1371 Forwards -> '/'
1372 Backwards -> '\\'
1373
1374 makeRelativeTo :: FilePath -> FilePath -> FilePath
1375 this `makeRelativeTo` that = directory </> thisFilename
1376 where (thisDirectory, thisFilename) = splitFileName this
1377 thatDirectory = dropFileName that
1378 directory = joinPath $ f (splitPath thisDirectory)
1379 (splitPath thatDirectory)
1380
1381 f (x : xs) (y : ys)
1382 | x == y = f xs ys
1383 f xs ys = replicate (length ys) ".." ++ xs
1384
1385 {-
1386 ************************************************************************
1387 * *
1388 \subsection[Utils-Data]{Utils for defining Data instances}
1389 * *
1390 ************************************************************************
1391
1392 These functions helps us to define Data instances for abstract types.
1393 -}
1394
1395 abstractConstr :: String -> Constr
1396 abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
1397
1398 abstractDataType :: String -> DataType
1399 abstractDataType n = mkDataType n [abstractConstr n]
1400
1401 {-
1402 ************************************************************************
1403 * *
1404 \subsection[Utils-C]{Utils for printing C code}
1405 * *
1406 ************************************************************************
1407 -}
1408
1409 charToC :: Word8 -> String
1410 charToC w =
1411 case chr (fromIntegral w) of
1412 '\"' -> "\\\""
1413 '\'' -> "\\\'"
1414 '\\' -> "\\\\"
1415 c | c >= ' ' && c <= '~' -> [c]
1416 | otherwise -> ['\\',
1417 chr (ord '0' + ord c `div` 64),
1418 chr (ord '0' + ord c `div` 8 `mod` 8),
1419 chr (ord '0' + ord c `mod` 8)]
1420
1421 {-
1422 ************************************************************************
1423 * *
1424 \subsection[Utils-Hashing]{Utils for hashing}
1425 * *
1426 ************************************************************************
1427 -}
1428
1429 -- | A sample hash function for Strings. We keep multiplying by the
1430 -- golden ratio and adding. The implementation is:
1431 --
1432 -- > hashString = foldl' f golden
1433 -- > where f m c = fromIntegral (ord c) * magic + hashInt32 m
1434 -- > magic = 0xdeadbeef
1435 --
1436 -- Where hashInt32 works just as hashInt shown above.
1437 --
1438 -- Knuth argues that repeated multiplication by the golden ratio
1439 -- will minimize gaps in the hash space, and thus it's a good choice
1440 -- for combining together multiple keys to form one.
1441 --
1442 -- Here we know that individual characters c are often small, and this
1443 -- produces frequent collisions if we use ord c alone. A
1444 -- particular problem are the shorter low ASCII and ISO-8859-1
1445 -- character strings. We pre-multiply by a magic twiddle factor to
1446 -- obtain a good distribution. In fact, given the following test:
1447 --
1448 -- > testp :: Int32 -> Int
1449 -- > testp k = (n - ) . length . group . sort . map hs . take n $ ls
1450 -- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]
1451 -- > hs = foldl' f golden
1452 -- > f m c = fromIntegral (ord c) * k + hashInt32 m
1453 -- > n = 100000
1454 --
1455 -- We discover that testp magic = 0.
1456 hashString :: String -> Int32
1457 hashString = foldl' f golden
1458 where f m c = fromIntegral (ord c) * magic + hashInt32 m
1459 magic = fromIntegral (0xdeadbeef :: Word32)
1460
1461 golden :: Int32
1462 golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32
1463 -- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32
1464 -- but that has bad mulHi properties (even adding 2^32 to get its inverse)
1465 -- Whereas the above works well and contains no hash duplications for
1466 -- [-32767..65536]
1467
1468 -- | A sample (and useful) hash function for Int32,
1469 -- implemented by extracting the uppermost 32 bits of the 64-bit
1470 -- result of multiplying by a 33-bit constant. The constant is from
1471 -- Knuth, derived from the golden ratio:
1472 --
1473 -- > golden = round ((sqrt 5 - 1) * 2^32)
1474 --
1475 -- We get good key uniqueness on small inputs
1476 -- (a problem with previous versions):
1477 -- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768
1478 --
1479 hashInt32 :: Int32 -> Int32
1480 hashInt32 x = mulHi x golden + x
1481
1482 -- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply
1483 mulHi :: Int32 -> Int32 -> Int32
1484 mulHi a b = fromIntegral (r `shiftR` 32)
1485 where r :: Int64
1486 r = fromIntegral a * fromIntegral b
1487
1488 -- | A call stack constraint, but only when 'isDebugOn'.
1489 #if defined(DEBUG)
1490 type HasDebugCallStack = HasCallStack
1491 #else
1492 type HasDebugCallStack = (() :: Constraint)
1493 #endif
1494
1495 data OverridingBool
1496 = Auto
1497 | Always
1498 | Never
1499 deriving Show
1500
1501 overrideWith :: Bool -> OverridingBool -> Bool
1502 overrideWith b Auto = b
1503 overrideWith _ Always = True
1504 overrideWith _ Never = False