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