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