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