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