Fix ghci tab completion of duplicate identifiers.
[ghc.git] / compiler / utils / Util.lhs
1 %
2 % (c) The University of Glasgow 2006
3 %
4
5 \begin{code}
6 {-# LANGUAGE CPP #-}
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         unzipWith,
21
22         mapFst, mapSnd, chkAppend,
23         mapAndUnzip, mapAndUnzip3, mapAccumL2,
24         nOfThem, filterOut, partitionWith, splitEithers,
25
26         foldl1', foldl2, count, all2,
27
28         lengthExceeds, lengthIs, lengthAtLeast,
29         listLengthCmp, atLength, equalLength, compareLength,
30
31         isSingleton, only, singleton,
32         notNull, snocView,
33
34         isIn, isn'tIn,
35
36         -- * Tuples
37         fstOf3, sndOf3, thirdOf3,
38         firstM, first3M,
39         third3,
40         uncurry3,
41
42         -- * List operations controlled by another list
43         takeList, dropList, splitAtList, split,
44         dropTail,
45
46         -- * For loop
47         nTimes,
48
49         -- * Sorting
50         sortWith, minWith, nubSort,
51
52         -- * Comparisons
53         isEqual, eqListBy, eqMaybeBy,
54         thenCmp, cmpList,
55         removeSpaces,
56
57         -- * Edit distance
58         fuzzyMatch, fuzzyLookup,
59
60         -- * Transitive closures
61         transitiveClosure,
62
63         -- * Strictness
64         seqList,
65
66         -- * Module names
67         looksLikeModuleName,
68
69         -- * Argument processing
70         getCmd, toCmdArgs, toArgs,
71
72         -- * Floating point
73         readRational,
74
75         -- * read helpers
76         maybeRead, maybeReadFuzzy,
77
78         -- * IO-ish utilities
79         doesDirNameExist,
80         getModificationUTCTime,
81         modificationTimeIfExists,
82
83         global, consIORef, globalM,
84
85         -- * Filenames and paths
86         Suffix,
87         splitLongestPrefix,
88         escapeSpaces,
89         parseSearchPath,
90         Direction(..), reslash,
91         makeRelativeTo,
92
93         -- * Utils for defining Data instances
94         abstractConstr, abstractDataType, mkNoRepType,
95
96         -- * Utils for printing C code
97         charToC,
98
99         -- * Hashing
100         hashString,
101     ) where
102
103 #include "HsVersions.h"
104
105 import Exception
106 import Panic
107
108 import Data.Data
109 import Data.IORef       ( IORef, newIORef, atomicModifyIORef )
110 import System.IO.Unsafe ( unsafePerformIO )
111 import Data.List        hiding (group)
112
113 #ifdef DEBUG
114 import FastTypes
115 #endif
116
117 import Control.Monad    ( liftM )
118 import System.IO.Error as IO ( isDoesNotExistError )
119 import System.Directory ( doesDirectoryExist, getModificationTime )
120 import System.FilePath
121
122 import Data.Char        ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit )
123 import Data.Int
124 import Data.Ratio       ( (%) )
125 import Data.Ord         ( comparing )
126 import Data.Bits
127 import Data.Word
128 import qualified Data.IntMap as IM
129 import qualified Data.Set as Set
130
131 import Data.Time
132 #if __GLASGOW_HASKELL__ < 705
133 import Data.Time.Clock.POSIX
134 import System.Time
135 #endif
136
137 infixr 9 `thenCmp`
138 \end{code}
139
140 %************************************************************************
141 %*                                                                      *
142 \subsection{Is DEBUG on, are we on Windows, etc?}
143 %*                                                                      *
144 %************************************************************************
145
146 These booleans are global constants, set by CPP flags.  They allow us to
147 recompile a single module (this one) to change whether or not debug output
148 appears. They sometimes let us avoid even running CPP elsewhere.
149
150 It's important that the flags are literal constants (True/False). Then,
151 with -0, tests of the flags in other modules will simplify to the correct
152 branch of the conditional, thereby dropping debug code altogether when
153 the flags are off.
154
155 \begin{code}
156 ghciSupported :: Bool
157 #ifdef GHCI
158 ghciSupported = True
159 #else
160 ghciSupported = False
161 #endif
162
163 debugIsOn :: Bool
164 #ifdef DEBUG
165 debugIsOn = True
166 #else
167 debugIsOn = False
168 #endif
169
170 ncgDebugIsOn :: Bool
171 #ifdef NCG_DEBUG
172 ncgDebugIsOn = True
173 #else
174 ncgDebugIsOn = False
175 #endif
176
177 ghciTablesNextToCode :: Bool
178 #ifdef GHCI_TABLES_NEXT_TO_CODE
179 ghciTablesNextToCode = True
180 #else
181 ghciTablesNextToCode = False
182 #endif
183
184 isWindowsHost :: Bool
185 #ifdef mingw32_HOST_OS
186 isWindowsHost = True
187 #else
188 isWindowsHost = False
189 #endif
190
191 isDarwinHost :: Bool
192 #ifdef darwin_HOST_OS
193 isDarwinHost = True
194 #else
195 isDarwinHost = False
196 #endif
197 \end{code}
198
199 %************************************************************************
200 %*                                                                      *
201 \subsection{A for loop}
202 %*                                                                      *
203 %************************************************************************
204
205 \begin{code}
206 -- | Compose a function with itself n times.  (nth rather than twice)
207 nTimes :: Int -> (a -> a) -> (a -> a)
208 nTimes 0 _ = id
209 nTimes 1 f = f
210 nTimes n f = f . nTimes (n-1) f
211 \end{code}
212
213 \begin{code}
214 fstOf3   :: (a,b,c) -> a
215 sndOf3   :: (a,b,c) -> b
216 thirdOf3 :: (a,b,c) -> c
217 fstOf3      (a,_,_) =  a
218 sndOf3      (_,b,_) =  b
219 thirdOf3    (_,_,c) =  c
220
221 third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
222 third3 f (a, b, c) = (a, b, f c)
223
224 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
225 uncurry3 f (a, b, c) = f a b c
226 \end{code}
227
228 \begin{code}
229 firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b)
230 firstM f (x, y) = liftM (\x' -> (x', y)) (f x)
231
232 first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c)
233 first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x)
234 \end{code}
235
236 %************************************************************************
237 %*                                                                      *
238 \subsection[Utils-lists]{General list processing}
239 %*                                                                      *
240 %************************************************************************
241
242 \begin{code}
243 filterOut :: (a->Bool) -> [a] -> [a]
244 -- ^ Like filter, only it reverses the sense of the test
245 filterOut _ [] = []
246 filterOut p (x:xs) | p x       = filterOut p xs
247                    | otherwise = x : filterOut p xs
248
249 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
250 -- ^ Uses a function to determine which of two output lists an input element should join
251 partitionWith _ [] = ([],[])
252 partitionWith f (x:xs) = case f x of
253                          Left  b -> (b:bs, cs)
254                          Right c -> (bs, c:cs)
255     where (bs,cs) = partitionWith f xs
256
257 splitEithers :: [Either a b] -> ([a], [b])
258 -- ^ Teases a list of 'Either's apart into two lists
259 splitEithers [] = ([],[])
260 splitEithers (e : es) = case e of
261                         Left x -> (x:xs, ys)
262                         Right y -> (xs, y:ys)
263     where (xs,ys) = splitEithers es
264
265 chkAppend :: [a] -> [a] -> [a]
266 -- Checks for the second arguemnt being empty
267 -- Used in situations where that situation is common
268 chkAppend xs ys 
269   | null ys   = xs
270   | otherwise = xs ++ ys
271 \end{code}
272
273 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
274 are of equal length.  Alastair Reid thinks this should only happen if
275 DEBUGging on; hey, why not?
276
277 \begin{code}
278 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
279 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
280 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
281 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
282
283 #ifndef DEBUG
284 zipEqual      _ = zip
285 zipWithEqual  _ = zipWith
286 zipWith3Equal _ = zipWith3
287 zipWith4Equal _ = zipWith4
288 #else
289 zipEqual _   []     []     = []
290 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
291 zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
292
293 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
294 zipWithEqual _   _ [] []        =  []
295 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
296
297 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
298                                 =  z a b c : zipWith3Equal msg z as bs cs
299 zipWith3Equal _   _ [] []  []   =  []
300 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
301
302 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
303                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
304 zipWith4Equal _   _ [] [] [] [] =  []
305 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
306 #endif
307 \end{code}
308
309 \begin{code}
310 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
311 zipLazy :: [a] -> [b] -> [(a,b)]
312 zipLazy []     _       = []
313 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
314 \end{code}
315
316
317 \begin{code}
318 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
319 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
320 -- the places where @p@ returns @True@
321
322 stretchZipWith _ _ _ []     _ = []
323 stretchZipWith p z f (x:xs) ys
324   | p x       = f x z : stretchZipWith p z f xs ys
325   | otherwise = case ys of
326                 []     -> []
327                 (y:ys) -> f x y : stretchZipWith p z f xs ys
328 \end{code}
329
330
331 \begin{code}
332 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
333 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
334
335 mapFst f xys = [(f x, y) | (x,y) <- xys]
336 mapSnd f xys = [(x, f y) | (x,y) <- xys]
337
338 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
339
340 mapAndUnzip _ [] = ([], [])
341 mapAndUnzip f (x:xs)
342   = let (r1,  r2)  = f x
343         (rs1, rs2) = mapAndUnzip f xs
344     in
345     (r1:rs1, r2:rs2)
346
347 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
348
349 mapAndUnzip3 _ [] = ([], [], [])
350 mapAndUnzip3 f (x:xs)
351   = let (r1,  r2,  r3)  = f x
352         (rs1, rs2, rs3) = mapAndUnzip3 f xs
353     in
354     (r1:rs1, r2:rs2, r3:rs3)
355
356 zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d])
357 zipWithAndUnzip f (a:as) (b:bs)
358   = let (r1,  r2)  = f a b
359         (rs1, rs2) = zipWithAndUnzip f as bs
360     in
361     (r1:rs1, r2:rs2)
362 zipWithAndUnzip _ _ _ = ([],[])
363
364 mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b])
365 mapAccumL2 f s1 s2 xs = (s1', s2', ys)
366   where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of
367                                                        (s1', s2', y) -> ((s1', s2'), y))
368                                      (s1, s2) xs
369 \end{code}
370
371 \begin{code}
372 nOfThem :: Int -> a -> [a]
373 nOfThem n thing = replicate n thing
374
375 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
376 --
377 -- @
378 --  atLength atLenPred atEndPred ls n
379 --   | n < 0         = atLenPred n
380 --   | length ls < n = atEndPred (n - length ls)
381 --   | otherwise     = atLenPred (drop n ls)
382 -- @
383 atLength :: ([a] -> b)
384          -> (Int -> b)
385          -> [a]
386          -> Int
387          -> b
388 atLength atLenPred atEndPred ls n
389   | n < 0     = atEndPred n
390   | otherwise = go n ls
391   where
392     go n [] = atEndPred n
393     go 0 ls = atLenPred ls
394     go n (_:xs) = go (n-1) xs
395
396 -- Some special cases of atLength:
397
398 lengthExceeds :: [a] -> Int -> Bool
399 -- ^ > (lengthExceeds xs n) = (length xs > n)
400 lengthExceeds = atLength notNull (const False)
401
402 lengthAtLeast :: [a] -> Int -> Bool
403 lengthAtLeast = atLength notNull (== 0)
404
405 lengthIs :: [a] -> Int -> Bool
406 lengthIs = atLength null (==0)
407
408 listLengthCmp :: [a] -> Int -> Ordering
409 listLengthCmp = atLength atLen atEnd
410  where
411   atEnd 0      = EQ
412   atEnd x
413    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
414    | otherwise = GT
415
416   atLen []     = EQ
417   atLen _      = GT
418
419 equalLength :: [a] -> [b] -> Bool
420 equalLength []     []     = True
421 equalLength (_:xs) (_:ys) = equalLength xs ys
422 equalLength _      _      = False
423
424 compareLength :: [a] -> [b] -> Ordering
425 compareLength []     []     = EQ
426 compareLength (_:xs) (_:ys) = compareLength xs ys
427 compareLength []     _      = LT
428 compareLength _      []     = GT
429
430 ----------------------------
431 singleton :: a -> [a]
432 singleton x = [x]
433
434 isSingleton :: [a] -> Bool
435 isSingleton [_] = True
436 isSingleton _   = False
437
438 notNull :: [a] -> Bool
439 notNull [] = False
440 notNull _  = True
441
442 only :: [a] -> a
443 #ifdef DEBUG
444 only [a] = a
445 #else
446 only (a:_) = a
447 #endif
448 only _ = panic "Util: only"
449 \end{code}
450
451 Debugging/specialising versions of \tr{elem} and \tr{notElem}
452
453 \begin{code}
454 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
455
456 # ifndef DEBUG
457 isIn    _msg x ys = x `elem` ys
458 isn'tIn _msg x ys = x `notElem` ys
459
460 # else /* DEBUG */
461 isIn msg x ys
462   = elem100 (_ILIT(0)) x ys
463   where
464     elem100 _ _ []        = False
465     elem100 i x (y:ys)
466       | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
467                                 (x `elem` (y:ys))
468       | otherwise       = x == y || elem100 (i +# _ILIT(1)) x ys
469
470 isn'tIn msg x ys
471   = notElem100 (_ILIT(0)) x ys
472   where
473     notElem100 _ _ [] =  True
474     notElem100 i x (y:ys)
475       | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
476                                 (x `notElem` (y:ys))
477       | otherwise      =  x /= y && notElem100 (i +# _ILIT(1)) x ys
478 # endif /* DEBUG */
479 \end{code}
480
481 %************************************************************************
482 %*                                                                      *
483 \subsubsection{Sort utils}
484 %*                                                                      *
485 %************************************************************************
486
487 \begin{code}
488 sortWith :: Ord b => (a->b) -> [a] -> [a]
489 sortWith get_key xs = sortBy (comparing get_key) xs
490
491 minWith :: Ord b => (a -> b) -> [a] -> a
492 minWith get_key xs = ASSERT( not (null xs) )
493                      head (sortWith get_key xs)
494
495 nubSort :: Ord a => [a] -> [a]
496 nubSort = Set.toAscList . Set.fromList
497 \end{code}
498
499 %************************************************************************
500 %*                                                                      *
501 \subsection[Utils-transitive-closure]{Transitive closure}
502 %*                                                                      *
503 %************************************************************************
504
505 This algorithm for transitive closure is straightforward, albeit quadratic.
506
507 \begin{code}
508 transitiveClosure :: (a -> [a])         -- Successor function
509                   -> (a -> a -> Bool)   -- Equality predicate
510                   -> [a]
511                   -> [a]                -- The transitive closure
512
513 transitiveClosure succ eq xs
514  = go [] xs
515  where
516    go done []                      = done
517    go done (x:xs) | x `is_in` done = go done xs
518                   | otherwise      = go (x:done) (succ x ++ xs)
519
520    _ `is_in` []                 = False
521    x `is_in` (y:ys) | eq x y    = True
522                     | otherwise = x `is_in` ys
523 \end{code}
524
525 %************************************************************************
526 %*                                                                      *
527 \subsection[Utils-accum]{Accumulating}
528 %*                                                                      *
529 %************************************************************************
530
531 A combination of foldl with zip.  It works with equal length lists.
532
533 \begin{code}
534 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
535 foldl2 _ z [] [] = z
536 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
537 foldl2 _ _ _      _      = panic "Util: foldl2"
538
539 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
540 -- True if the lists are the same length, and
541 -- all corresponding elements satisfy the predicate
542 all2 _ []     []     = True
543 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
544 all2 _ _      _      = False
545 \end{code}
546
547 Count the number of times a predicate is true
548
549 \begin{code}
550 count :: (a -> Bool) -> [a] -> Int
551 count _ [] = 0
552 count p (x:xs) | p x       = 1 + count p xs
553                | otherwise = count p xs
554 \end{code}
555
556 @splitAt@, @take@, and @drop@ but with length of another
557 list giving the break-off point:
558
559 \begin{code}
560 takeList :: [b] -> [a] -> [a]
561 takeList [] _ = []
562 takeList (_:xs) ls =
563    case ls of
564      [] -> []
565      (y:ys) -> y : takeList xs ys
566
567 dropList :: [b] -> [a] -> [a]
568 dropList [] xs    = xs
569 dropList _  xs@[] = xs
570 dropList (_:xs) (_:ys) = dropList xs ys
571
572
573 splitAtList :: [b] -> [a] -> ([a], [a])
574 splitAtList [] xs     = ([], xs)
575 splitAtList _ xs@[]   = (xs, xs)
576 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
577     where
578       (ys', ys'') = splitAtList xs ys
579
580 -- drop from the end of a list
581 dropTail :: Int -> [a] -> [a]
582 -- Specification: dropTail n = reverse . drop n . reverse
583 -- Better implemention due to Joachim Breitner
584 -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html
585 dropTail n xs
586   = go (drop n xs) xs
587   where
588     go (_:ys) (x:xs) = x : go ys xs 
589     go _      _      = []  -- Stop when ys runs out
590                            -- It'll always run out before xs does
591
592 snocView :: [a] -> Maybe ([a],a)
593         -- Split off the last element
594 snocView [] = Nothing
595 snocView xs = go [] xs
596             where
597                 -- Invariant: second arg is non-empty
598               go acc [x]    = Just (reverse acc, x)
599               go acc (x:xs) = go (x:acc) xs
600               go _   []     = panic "Util: snocView"
601
602 split :: Char -> String -> [String]
603 split c s = case rest of
604                 []     -> [chunk]
605                 _:rest -> chunk : split c rest
606   where (chunk, rest) = break (==c) s
607 \end{code}
608
609
610 %************************************************************************
611 %*                                                                      *
612 \subsection[Utils-comparison]{Comparisons}
613 %*                                                                      *
614 %************************************************************************
615
616 \begin{code}
617 isEqual :: Ordering -> Bool
618 -- Often used in (isEqual (a `compare` b))
619 isEqual GT = False
620 isEqual EQ = True
621 isEqual LT = False
622
623 thenCmp :: Ordering -> Ordering -> Ordering
624 {-# INLINE thenCmp #-}
625 thenCmp EQ       ordering = ordering
626 thenCmp ordering _        = ordering
627
628 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
629 eqListBy _  []     []     = True
630 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
631 eqListBy _  _      _      = False
632
633 eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool
634 eqMaybeBy _  Nothing  Nothing  = True
635 eqMaybeBy eq (Just x) (Just y) = eq x y
636 eqMaybeBy _  _        _        = False
637
638 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
639     -- `cmpList' uses a user-specified comparer
640
641 cmpList _   []     [] = EQ
642 cmpList _   []     _  = LT
643 cmpList _   _      [] = GT
644 cmpList cmp (a:as) (b:bs)
645   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
646 \end{code}
647
648 \begin{code}
649 removeSpaces :: String -> String
650 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
651 \end{code}
652
653 %************************************************************************
654 %*                                                                      *
655 \subsection{Edit distance}
656 %*                                                                      *
657 %************************************************************************
658
659 \begin{code}
660 -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings.
661 -- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.
662 -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing
663 -- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).
664 -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and
665 --     http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation
666 restrictedDamerauLevenshteinDistance :: String -> String -> Int
667 restrictedDamerauLevenshteinDistance str1 str2
668   = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
669   where
670     m = length str1
671     n = length str2
672
673 restrictedDamerauLevenshteinDistanceWithLengths
674   :: Int -> Int -> String -> String -> Int
675 restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
676   | m <= n
677   = if n <= 32 -- n must be larger so this check is sufficient
678     then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2
679     else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2
680
681   | otherwise
682   = if m <= 32 -- m must be larger so this check is sufficient
683     then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1
684     else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1
685
686 restrictedDamerauLevenshteinDistance'
687   :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int
688 restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
689   | [] <- str1 = n
690   | otherwise  = extractAnswer $
691                  foldl' (restrictedDamerauLevenshteinDistanceWorker
692                              (matchVectors str1) top_bit_mask vector_mask)
693                         (0, 0, m_ones, 0, m) str2
694   where
695     m_ones@vector_mask = (2 ^ m) - 1
696     top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy
697     extractAnswer (_, _, _, _, distance) = distance
698
699 restrictedDamerauLevenshteinDistanceWorker
700       :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv
701       -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
702 restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask
703                                            (pm, d0, vp, vn, distance) char2
704   = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $
705     seq pm' $ seq d0' $ seq vp' $ seq vn' $
706     seq distance'' $ seq char2 $
707     (pm', d0', vp', vn', distance'')
708   where
709     pm' = IM.findWithDefault 0 (ord char2) str1_mvs
710
711     d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm)
712       .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn
713           -- No need to mask the shiftL because of the restricted range of pm
714
715     hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)
716     hn' = d0' .&. vp
717
718     hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask
719     hn'_shift = (hn' `shiftL` 1) .&. vector_mask
720     vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)
721     vn' = d0' .&. hp'_shift
722
723     distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance
724     distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
725
726 sizedComplement :: Bits bv => bv -> bv -> bv
727 sizedComplement vector_mask vect = vector_mask `xor` vect
728
729 matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv
730 matchVectors = snd . foldl' go (0 :: Int, IM.empty)
731   where
732     go (ix, im) char = let ix' = ix + 1
733                            im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im
734                        in seq ix' $ seq im' $ (ix', im')
735
736 #ifdef __GLASGOW_HASKELL__
737 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
738                       :: Word32 -> Int -> Int -> String -> String -> Int #-}
739 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
740                       :: Integer -> Int -> Int -> String -> String -> Int #-}
741
742 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
743                :: IM.IntMap Word32 -> Word32 -> Word32
744                -> (Word32, Word32, Word32, Word32, Int)
745                -> Char -> (Word32, Word32, Word32, Word32, Int) #-}
746 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
747                :: IM.IntMap Integer -> Integer -> Integer
748                -> (Integer, Integer, Integer, Integer, Int)
749                -> Char -> (Integer, Integer, Integer, Integer, Int) #-}
750
751 {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}
752 {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}
753
754 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}
755 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}
756 #endif
757
758 fuzzyMatch :: String -> [String] -> [String]
759 fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals]
760
761 -- | Search for possible matches to the users input in the given list,
762 -- returning a small number of ranked results
763 fuzzyLookup :: String -> [(String,a)] -> [a]
764 fuzzyLookup user_entered possibilites
765   = map fst $ take mAX_RESULTS $ sortBy (comparing snd)
766     [ (poss_val, distance) | (poss_str, poss_val) <- possibilites
767                        , let distance = restrictedDamerauLevenshteinDistance
768                                             poss_str user_entered
769                        , distance <= fuzzy_threshold ]
770   where
771     -- Work out an approriate match threshold:
772     -- We report a candidate if its edit distance is <= the threshold,
773     -- The threshhold is set to about a quarter of the # of characters the user entered
774     --   Length    Threshold
775     --     1         0          -- Don't suggest *any* candidates
776     --     2         1          -- for single-char identifiers
777     --     3         1
778     --     4         1
779     --     5         1
780     --     6         2
781     --
782     fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational)
783     mAX_RESULTS = 3
784 \end{code}
785
786 %************************************************************************
787 %*                                                                      *
788 \subsection[Utils-pairs]{Pairs}
789 %*                                                                      *
790 %************************************************************************
791
792 \begin{code}
793 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
794 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
795 \end{code}
796
797 \begin{code}
798 seqList :: [a] -> b -> b
799 seqList [] b = b
800 seqList (x:xs) b = x `seq` seqList xs b
801 \end{code}
802
803 Global variables:
804
805 \begin{code}
806 global :: a -> IORef a
807 global a = unsafePerformIO (newIORef a)
808 \end{code}
809
810 \begin{code}
811 consIORef :: IORef [a] -> a -> IO ()
812 consIORef var x = do
813   atomicModifyIORef var (\xs -> (x:xs,()))
814 \end{code}
815
816 \begin{code}
817 globalM :: IO a -> IORef a
818 globalM ma = unsafePerformIO (ma >>= newIORef)
819 \end{code}
820
821 Module names:
822
823 \begin{code}
824 looksLikeModuleName :: String -> Bool
825 looksLikeModuleName [] = False
826 looksLikeModuleName (c:cs) = isUpper c && go cs
827   where go [] = True
828         go ('.':cs) = looksLikeModuleName cs
829         go (c:cs)   = (isAlphaNum c || c == '_' || c == '\'') && go cs
830 \end{code}
831
832 Akin to @Prelude.words@, but acts like the Bourne shell, treating
833 quoted strings as Haskell Strings, and also parses Haskell [String]
834 syntax.
835
836 \begin{code}
837 getCmd :: String -> Either String             -- Error
838                            (String, String) -- (Cmd, Rest)
839 getCmd s = case break isSpace $ dropWhile isSpace s of
840            ([], _) -> Left ("Couldn't find command in " ++ show s)
841            res -> Right res
842
843 toCmdArgs :: String -> Either String             -- Error
844                               (String, [String]) -- (Cmd, Args)
845 toCmdArgs s = case getCmd s of
846               Left err -> Left err
847               Right (cmd, s') -> case toArgs s' of
848                                  Left err -> Left err
849                                  Right args -> Right (cmd, args)
850
851 toArgs :: String -> Either String   -- Error
852                            [String] -- Args
853 toArgs str
854     = case dropWhile isSpace str of
855       s@('[':_) -> case reads s of
856                    [(args, spaces)]
857                     | all isSpace spaces ->
858                        Right args
859                    _ ->
860                        Left ("Couldn't read " ++ show str ++ "as [String]")
861       s -> toArgs' s
862  where
863   toArgs' s = case dropWhile isSpace s of
864               [] -> Right []
865               ('"' : _) -> case reads s of
866                            [(arg, rest)]
867                               -- rest must either be [] or start with a space
868                             | all isSpace (take 1 rest) ->
869                                case toArgs' rest of
870                                Left err -> Left err
871                                Right args -> Right (arg : args)
872                            _ ->
873                                Left ("Couldn't read " ++ show s ++ "as String")
874               s' -> case break isSpace s' of
875                     (arg, s'') -> case toArgs' s'' of
876                                   Left err -> Left err
877                                   Right args -> Right (arg : args)
878 \end{code}
879
880 -- -----------------------------------------------------------------------------
881 -- Floats
882
883 \begin{code}
884 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
885 readRational__ r = do
886      (n,d,s) <- readFix r
887      (k,t)   <- readExp s
888      return ((n%1)*10^^(k-d), t)
889  where
890      readFix r = do
891         (ds,s)  <- lexDecDigits r
892         (ds',t) <- lexDotDigits s
893         return (read (ds++ds'), length ds', t)
894
895      readExp (e:s) | e `elem` "eE" = readExp' s
896      readExp s                     = return (0,s)
897
898      readExp' ('+':s) = readDec s
899      readExp' ('-':s) = do (k,t) <- readDec s
900                            return (-k,t)
901      readExp' s       = readDec s
902
903      readDec s = do
904         (ds,r) <- nonnull isDigit s
905         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
906                 r)
907
908      lexDecDigits = nonnull isDigit
909
910      lexDotDigits ('.':s) = return (span isDigit s)
911      lexDotDigits s       = return ("",s)
912
913      nonnull p s = do (cs@(_:_),t) <- return (span p s)
914                       return (cs,t)
915
916 readRational :: String -> Rational -- NB: *does* handle a leading "-"
917 readRational top_s
918   = case top_s of
919       '-' : xs -> - (read_me xs)
920       xs       -> read_me xs
921   where
922     read_me s
923       = case (do { (x,"") <- readRational__ s ; return x }) of
924           [x] -> x
925           []  -> error ("readRational: no parse:"        ++ top_s)
926           _   -> error ("readRational: ambiguous parse:" ++ top_s)
927
928
929 -----------------------------------------------------------------------------
930 -- read helpers
931
932 maybeRead :: Read a => String -> Maybe a
933 maybeRead str = case reads str of
934                 [(x, "")] -> Just x
935                 _         -> Nothing
936
937 maybeReadFuzzy :: Read a => String -> Maybe a
938 maybeReadFuzzy str = case reads str of
939                      [(x, s)]
940                       | all isSpace s ->
941                          Just x
942                      _ ->
943                          Nothing
944
945 -----------------------------------------------------------------------------
946 -- Verify that the 'dirname' portion of a FilePath exists.
947 --
948 doesDirNameExist :: FilePath -> IO Bool
949 doesDirNameExist fpath = case takeDirectory fpath of
950                          "" -> return True -- XXX Hack
951                          _  -> doesDirectoryExist (takeDirectory fpath)
952
953 -----------------------------------------------------------------------------
954 -- Backwards compatibility definition of getModificationTime
955
956 getModificationUTCTime :: FilePath -> IO UTCTime
957 #if __GLASGOW_HASKELL__ < 705
958 getModificationUTCTime f = do
959     TOD secs _ <- getModificationTime f
960     return $ posixSecondsToUTCTime (realToFrac secs)
961 #else
962 getModificationUTCTime = getModificationTime
963 #endif
964
965 -- --------------------------------------------------------------
966 -- check existence & modification time at the same time
967
968 modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)
969 modificationTimeIfExists f = do
970   (do t <- getModificationUTCTime f; return (Just t))
971         `catchIO` \e -> if isDoesNotExistError e
972                         then return Nothing
973                         else ioError e
974
975 -- split a string at the last character where 'pred' is True,
976 -- returning a pair of strings. The first component holds the string
977 -- up (but not including) the last character for which 'pred' returned
978 -- True, the second whatever comes after (but also not including the
979 -- last character).
980 --
981 -- If 'pred' returns False for all characters in the string, the original
982 -- string is returned in the first component (and the second one is just
983 -- empty).
984 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
985 splitLongestPrefix str pred
986   | null r_pre = (str,           [])
987   | otherwise  = (reverse (tail r_pre), reverse r_suf)
988                            -- 'tail' drops the char satisfying 'pred'
989   where (r_suf, r_pre) = break pred (reverse str)
990
991 escapeSpaces :: String -> String
992 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
993
994 type Suffix = String
995
996 --------------------------------------------------------------
997 -- * Search path
998 --------------------------------------------------------------
999
1000 -- | The function splits the given string to substrings
1001 -- using the 'searchPathSeparator'.
1002 parseSearchPath :: String -> [FilePath]
1003 parseSearchPath path = split path
1004   where
1005     split :: String -> [String]
1006     split s =
1007       case rest' of
1008         []     -> [chunk]
1009         _:rest -> chunk : split rest
1010       where
1011         chunk =
1012           case chunk' of
1013 #ifdef mingw32_HOST_OS
1014             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1015 #endif
1016             _                                 -> chunk'
1017
1018         (chunk', rest') = break isSearchPathSeparator s
1019
1020 data Direction = Forwards | Backwards
1021
1022 reslash :: Direction -> FilePath -> FilePath
1023 reslash d = f
1024     where f ('/'  : xs) = slash : f xs
1025           f ('\\' : xs) = slash : f xs
1026           f (x    : xs) = x     : f xs
1027           f ""          = ""
1028           slash = case d of
1029                   Forwards -> '/'
1030                   Backwards -> '\\'
1031
1032 makeRelativeTo :: FilePath -> FilePath -> FilePath
1033 this `makeRelativeTo` that = directory </> thisFilename
1034     where (thisDirectory, thisFilename) = splitFileName this
1035           thatDirectory = dropFileName that
1036           directory = joinPath $ f (splitPath thisDirectory)
1037                                    (splitPath thatDirectory)
1038
1039           f (x : xs) (y : ys)
1040            | x == y = f xs ys
1041           f xs ys = replicate (length ys) ".." ++ xs
1042 \end{code}
1043
1044 %************************************************************************
1045 %*                                                                      *
1046 \subsection[Utils-Data]{Utils for defining Data instances}
1047 %*                                                                      *
1048 %************************************************************************
1049
1050 These functions helps us to define Data instances for abstract types.
1051
1052 \begin{code}
1053 abstractConstr :: String -> Constr
1054 abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
1055 \end{code}
1056
1057 \begin{code}
1058 abstractDataType :: String -> DataType
1059 abstractDataType n = mkDataType n [abstractConstr n]
1060 \end{code}
1061
1062 %************************************************************************
1063 %*                                                                      *
1064 \subsection[Utils-C]{Utils for printing C code}
1065 %*                                                                      *
1066 %************************************************************************
1067
1068 \begin{code}
1069 charToC :: Word8 -> String
1070 charToC w =
1071   case chr (fromIntegral w) of
1072         '\"' -> "\\\""
1073         '\'' -> "\\\'"
1074         '\\' -> "\\\\"
1075         c | c >= ' ' && c <= '~' -> [c]
1076           | otherwise -> ['\\',
1077                          chr (ord '0' + ord c `div` 64),
1078                          chr (ord '0' + ord c `div` 8 `mod` 8),
1079                          chr (ord '0' + ord c         `mod` 8)]
1080 \end{code}
1081
1082 %************************************************************************
1083 %*                                                                      *
1084 \subsection[Utils-Hashing]{Utils for hashing}
1085 %*                                                                      *
1086 %************************************************************************
1087
1088 \begin{code}
1089 -- | A sample hash function for Strings.  We keep multiplying by the
1090 -- golden ratio and adding.  The implementation is:
1091 --
1092 -- > hashString = foldl' f golden
1093 -- >   where f m c = fromIntegral (ord c) * magic + hashInt32 m
1094 -- >         magic = 0xdeadbeef
1095 --
1096 -- Where hashInt32 works just as hashInt shown above.
1097 --
1098 -- Knuth argues that repeated multiplication by the golden ratio
1099 -- will minimize gaps in the hash space, and thus it's a good choice
1100 -- for combining together multiple keys to form one.
1101 --
1102 -- Here we know that individual characters c are often small, and this
1103 -- produces frequent collisions if we use ord c alone.  A
1104 -- particular problem are the shorter low ASCII and ISO-8859-1
1105 -- character strings.  We pre-multiply by a magic twiddle factor to
1106 -- obtain a good distribution.  In fact, given the following test:
1107 --
1108 -- > testp :: Int32 -> Int
1109 -- > testp k = (n - ) . length . group . sort . map hs . take n $ ls
1110 -- >   where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']]
1111 -- >         hs = foldl' f golden
1112 -- >         f m c = fromIntegral (ord c) * k + hashInt32 m
1113 -- >         n = 100000
1114 --
1115 -- We discover that testp magic = 0.
1116 hashString :: String -> Int32
1117 hashString = foldl' f golden
1118    where f m c = fromIntegral (ord c) * magic + hashInt32 m
1119          magic = fromIntegral (0xdeadbeef :: Word32)
1120
1121 golden :: Int32
1122 golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32
1123 -- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32
1124 -- but that has bad mulHi properties (even adding 2^32 to get its inverse)
1125 -- Whereas the above works well and contains no hash duplications for
1126 -- [-32767..65536]
1127
1128 -- | A sample (and useful) hash function for Int32,
1129 -- implemented by extracting the uppermost 32 bits of the 64-bit
1130 -- result of multiplying by a 33-bit constant.  The constant is from
1131 -- Knuth, derived from the golden ratio:
1132 --
1133 -- > golden = round ((sqrt 5 - 1) * 2^32)
1134 --
1135 -- We get good key uniqueness on small inputs
1136 -- (a problem with previous versions):
1137 --  (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768
1138 --
1139 hashInt32 :: Int32 -> Int32
1140 hashInt32 x = mulHi x golden + x
1141
1142 -- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply
1143 mulHi :: Int32 -> Int32 -> Int32
1144 mulHi a b = fromIntegral (r `shiftR` 32)
1145    where r :: Int64
1146          r = fromIntegral a * fromIntegral b
1147 \end{code}
1148