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