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