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