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