2 % (c) The University of Glasgow 2006
3 % (c) The University of Glasgow 1992-2002
7 -- | Highly random utility functions
9 -- * Flags dependent on the compiler build
10 ghciSupported, debugIsOn, ghciTablesNextToCode, isDynamicGhcLib,
11 isWindowsHost, isWindowsTarget, isDarwinTarget,
13 -- * General list processing
14 zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
15 zipLazy, stretchZipWith,
20 mapAndUnzip, mapAndUnzip3,
21 nOfThem, filterOut, partitionWith, splitEithers,
23 foldl1', foldl2, count, all2,
25 lengthExceeds, lengthIs, lengthAtLeast,
26 listLengthCmp, atLength, equalLength, compareLength,
28 isSingleton, only, singleton,
34 fstOf3, sndOf3, thirdOf3,
36 -- * List operations controlled by another list
37 takeList, dropList, splitAtList, split,
54 -- * Transitive closures
63 -- * Argument processing
64 getCmd, toCmdArgs, toArgs,
70 createDirectoryHierarchy,
72 modificationTimeIfExists,
74 global, consIORef, globalMVar, globalEmptyMVar,
76 -- * Filenames and paths
81 Direction(..), reslash,
83 -- * Utils for defining Data instances
84 abstractConstr, abstractDataType, mkNoRepType
87 #include "HsVersions.h"
92 import Data.IORef ( IORef, newIORef, atomicModifyIORef )
93 import System.IO.Unsafe ( unsafePerformIO )
94 import Data.List hiding (group)
95 import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
101 import Control.Monad ( unless )
102 import System.IO.Error as IO ( catch, isDoesNotExistError )
103 import System.Directory ( doesDirectoryExist, createDirectory,
104 getModificationTime )
105 import System.FilePath
106 import System.Time ( ClockTime )
108 import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
109 import Data.Ratio ( (%) )
110 import Data.Ord ( comparing )
113 import qualified Data.IntMap as IM
118 %************************************************************************
120 \subsection{Is DEBUG on, are we on Windows, etc?}
122 %************************************************************************
124 These booleans are global constants, set by CPP flags. They allow us to
125 recompile a single module (this one) to change whether or not debug output
126 appears. They sometimes let us avoid even running CPP elsewhere.
128 It's important that the flags are literal constants (True/False). Then,
129 with -0, tests of the flags in other modules will simplify to the correct
130 branch of the conditional, thereby dropping debug code altogether when
134 ghciSupported :: Bool
138 ghciSupported = False
148 ghciTablesNextToCode :: Bool
149 #ifdef GHCI_TABLES_NEXT_TO_CODE
150 ghciTablesNextToCode = True
152 ghciTablesNextToCode = False
155 isDynamicGhcLib :: Bool
157 isDynamicGhcLib = True
159 isDynamicGhcLib = False
162 isWindowsHost :: Bool
163 #ifdef mingw32_HOST_OS
166 isWindowsHost = False
169 isWindowsTarget :: Bool
170 #ifdef mingw32_TARGET_OS
171 isWindowsTarget = True
173 isWindowsTarget = False
176 isDarwinTarget :: Bool
177 #ifdef darwin_TARGET_OS
178 isDarwinTarget = True
180 isDarwinTarget = False
184 %************************************************************************
186 \subsection{A for loop}
188 %************************************************************************
191 -- | Compose a function with itself n times. (nth rather than twice)
192 nTimes :: Int -> (a -> a) -> (a -> a)
195 nTimes n f = f . nTimes (n-1) f
199 fstOf3 :: (a,b,c) -> a
200 sndOf3 :: (a,b,c) -> b
201 thirdOf3 :: (a,b,c) -> c
207 %************************************************************************
209 \subsection[Utils-lists]{General list processing}
211 %************************************************************************
214 filterOut :: (a->Bool) -> [a] -> [a]
215 -- ^ Like filter, only it reverses the sense of the test
217 filterOut p (x:xs) | p x = filterOut p xs
218 | otherwise = x : filterOut p xs
220 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
221 -- ^ Uses a function to determine which of two output lists an input element should join
222 partitionWith _ [] = ([],[])
223 partitionWith f (x:xs) = case f x of
225 Right c -> (bs, c:cs)
226 where (bs,cs) = partitionWith f xs
228 splitEithers :: [Either a b] -> ([a], [b])
229 -- ^ Teases a list of 'Either's apart into two lists
230 splitEithers [] = ([],[])
231 splitEithers (e : es) = case e of
233 Right y -> (xs, y:ys)
234 where (xs,ys) = splitEithers es
237 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
238 are of equal length. Alastair Reid thinks this should only happen if
239 DEBUGging on; hey, why not?
242 zipEqual :: String -> [a] -> [b] -> [(a,b)]
243 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
244 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
245 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
249 zipWithEqual _ = zipWith
250 zipWith3Equal _ = zipWith3
251 zipWith4Equal _ = zipWith4
253 zipEqual _ [] [] = []
254 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
255 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
257 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
258 zipWithEqual _ _ [] [] = []
259 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
261 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
262 = z a b c : zipWith3Equal msg z as bs cs
263 zipWith3Equal _ _ [] [] [] = []
264 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
266 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
267 = z a b c d : zipWith4Equal msg z as bs cs ds
268 zipWith4Equal _ _ [] [] [] [] = []
269 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
274 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
275 zipLazy :: [a] -> [b] -> [(a,b)]
277 -- We want to write this, but with GHC 6.4 we get a warning, so it
279 -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
280 -- so we write this instead:
281 zipLazy (x:xs) zs = let y : ys = zs
282 in (x,y) : zipLazy xs ys
287 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
288 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
289 -- the places where @p@ returns @True@
291 stretchZipWith _ _ _ [] _ = []
292 stretchZipWith p z f (x:xs) ys
293 | p x = f x z : stretchZipWith p z f xs ys
294 | otherwise = case ys of
296 (y:ys) -> f x y : stretchZipWith p z f xs ys
301 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
302 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
304 mapFst f xys = [(f x, y) | (x,y) <- xys]
305 mapSnd f xys = [(x, f y) | (x,y) <- xys]
307 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
309 mapAndUnzip _ [] = ([], [])
312 (rs1, rs2) = mapAndUnzip f xs
316 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
318 mapAndUnzip3 _ [] = ([], [], [])
319 mapAndUnzip3 f (x:xs)
320 = let (r1, r2, r3) = f x
321 (rs1, rs2, rs3) = mapAndUnzip3 f xs
323 (r1:rs1, r2:rs2, r3:rs3)
327 nOfThem :: Int -> a -> [a]
328 nOfThem n thing = replicate n thing
330 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
333 -- atLength atLenPred atEndPred ls n
334 -- | n < 0 = atLenPred n
335 -- | length ls < n = atEndPred (n - length ls)
336 -- | otherwise = atLenPred (drop n ls)
338 atLength :: ([a] -> b)
343 atLength atLenPred atEndPred ls n
344 | n < 0 = atEndPred n
345 | otherwise = go n ls
347 go n [] = atEndPred n
348 go 0 ls = atLenPred ls
349 go n (_:xs) = go (n-1) xs
351 -- Some special cases of atLength:
353 lengthExceeds :: [a] -> Int -> Bool
354 -- ^ > (lengthExceeds xs n) = (length xs > n)
355 lengthExceeds = atLength notNull (const False)
357 lengthAtLeast :: [a] -> Int -> Bool
358 lengthAtLeast = atLength notNull (== 0)
360 lengthIs :: [a] -> Int -> Bool
361 lengthIs = atLength null (==0)
363 listLengthCmp :: [a] -> Int -> Ordering
364 listLengthCmp = atLength atLen atEnd
368 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
374 equalLength :: [a] -> [b] -> Bool
375 equalLength [] [] = True
376 equalLength (_:xs) (_:ys) = equalLength xs ys
377 equalLength _ _ = False
379 compareLength :: [a] -> [b] -> Ordering
380 compareLength [] [] = EQ
381 compareLength (_:xs) (_:ys) = compareLength xs ys
382 compareLength [] _ = LT
383 compareLength _ [] = GT
385 ----------------------------
386 singleton :: a -> [a]
389 isSingleton :: [a] -> Bool
390 isSingleton [_] = True
391 isSingleton _ = False
393 notNull :: [a] -> Bool
403 only _ = panic "Util: only"
406 Debugging/specialising versions of \tr{elem} and \tr{notElem}
409 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
412 isIn _msg x ys = x `elem` ys
413 isn'tIn _msg x ys = x `notElem` ys
417 = elem100 (_ILIT(0)) x ys
419 elem100 _ _ [] = False
421 | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
423 | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys
426 = notElem100 (_ILIT(0)) x ys
428 notElem100 _ _ [] = True
429 notElem100 i x (y:ys)
430 | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
432 | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys
436 %************************************************************************
438 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
440 %************************************************************************
443 Date: Mon, 3 May 93 20:45:23 +0200
444 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
445 To: partain@dcs.gla.ac.uk
446 Subject: natural merge sort beats quick sort [ and it is prettier ]
448 Here is a piece of Haskell code that I'm rather fond of. See it as an
449 attempt to get rid of the ridiculous quick-sort routine. group is
450 quite useful by itself I think it was John's idea originally though I
451 believe the lazy version is due to me [surprisingly complicated].
452 gamma [used to be called] is called gamma because I got inspired by
453 the Gamma calculus. It is not very close to the calculus but does
454 behave less sequentially than both foldr and foldl. One could imagine
455 a version of gamma that took a unit element as well thereby avoiding
456 the problem with empty lists.
458 I've tried this code against
460 1) insertion sort - as provided by haskell
461 2) the normal implementation of quick sort
462 3) a deforested version of quick sort due to Jan Sparud
463 4) a super-optimized-quick-sort of Lennart's
465 If the list is partially sorted both merge sort and in particular
466 natural merge sort wins. If the list is random [ average length of
467 rising subsequences = approx 2 ] mergesort still wins and natural
468 merge sort is marginally beaten by Lennart's soqs. The space
469 consumption of merge sort is a bit worse than Lennart's quick sort
470 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
471 fpca article ] isn't used because of group.
478 group :: (a -> a -> Bool) -> [a] -> [[a]]
479 -- Given a <= function, group finds maximal contiguous up-runs
480 -- or down-runs in the input list.
481 -- It's stable, in the sense that it never re-orders equal elements
483 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
484 -- From: Andy Gill <andy@dcs.gla.ac.uk>
485 -- Here is a `better' definition of group.
488 group p (x:xs) = group' xs x x (x :)
490 group' [] _ _ s = [s []]
491 group' (x:xs) x_min x_max s
492 | x_max `p` x = group' xs x_min x (s . (x :))
493 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
494 | otherwise = s [] : group' xs x x (x :)
495 -- NB: the 'not' is essential for stablity
496 -- x `p` x_min would reverse equal elements
498 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
499 generalMerge _ xs [] = xs
500 generalMerge _ [] ys = ys
501 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
502 | otherwise = y : generalMerge p (x:xs) ys
504 -- gamma is now called balancedFold
506 balancedFold :: (a -> a -> a) -> [a] -> a
507 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
508 balancedFold _ [x] = x
509 balancedFold f l = balancedFold f (balancedFold' f l)
511 balancedFold' :: (a -> a -> a) -> [a] -> [a]
512 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
513 balancedFold' _ xs = xs
515 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
516 generalNaturalMergeSort _ [] = []
517 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
520 generalMergeSort p [] = []
521 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
523 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
525 mergeSort = generalMergeSort (<=)
526 naturalMergeSort = generalNaturalMergeSort (<=)
528 mergeSortLe le = generalMergeSort le
531 sortLe :: (a->a->Bool) -> [a] -> [a]
532 sortLe le = generalNaturalMergeSort le
534 sortWith :: Ord b => (a->b) -> [a] -> [a]
535 sortWith get_key xs = sortLe le xs
537 x `le` y = get_key x < get_key y
539 on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
540 on cmp sel = \x y -> sel x `cmp` sel y
544 %************************************************************************
546 \subsection[Utils-transitive-closure]{Transitive closure}
548 %************************************************************************
550 This algorithm for transitive closure is straightforward, albeit quadratic.
553 transitiveClosure :: (a -> [a]) -- Successor function
554 -> (a -> a -> Bool) -- Equality predicate
556 -> [a] -- The transitive closure
558 transitiveClosure succ eq xs
562 go done (x:xs) | x `is_in` done = go done xs
563 | otherwise = go (x:done) (succ x ++ xs)
566 x `is_in` (y:ys) | eq x y = True
567 | otherwise = x `is_in` ys
570 %************************************************************************
572 \subsection[Utils-accum]{Accumulating}
574 %************************************************************************
576 A combination of foldl with zip. It works with equal length lists.
579 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
581 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
582 foldl2 _ _ _ _ = panic "Util: foldl2"
584 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
585 -- True if the lists are the same length, and
586 -- all corresponding elements satisfy the predicate
588 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
592 Count the number of times a predicate is true
595 count :: (a -> Bool) -> [a] -> Int
597 count p (x:xs) | p x = 1 + count p xs
598 | otherwise = count p xs
601 @splitAt@, @take@, and @drop@ but with length of another
602 list giving the break-off point:
605 takeList :: [b] -> [a] -> [a]
610 (y:ys) -> y : takeList xs ys
612 dropList :: [b] -> [a] -> [a]
614 dropList _ xs@[] = xs
615 dropList (_:xs) (_:ys) = dropList xs ys
618 splitAtList :: [b] -> [a] -> ([a], [a])
619 splitAtList [] xs = ([], xs)
620 splitAtList _ xs@[] = (xs, xs)
621 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
623 (ys', ys'') = splitAtList xs ys
625 -- drop from the end of a list
626 dropTail :: Int -> [a] -> [a]
627 dropTail n = reverse . drop n . reverse
629 snocView :: [a] -> Maybe ([a],a)
630 -- Split off the last element
631 snocView [] = Nothing
632 snocView xs = go [] xs
634 -- Invariant: second arg is non-empty
635 go acc [x] = Just (reverse acc, x)
636 go acc (x:xs) = go (x:acc) xs
637 go _ [] = panic "Util: snocView"
639 split :: Char -> String -> [String]
640 split c s = case rest of
642 _:rest -> chunk : split c rest
643 where (chunk, rest) = break (==c) s
647 %************************************************************************
649 \subsection[Utils-comparison]{Comparisons}
651 %************************************************************************
654 isEqual :: Ordering -> Bool
655 -- Often used in (isEqual (a `compare` b))
660 thenCmp :: Ordering -> Ordering -> Ordering
661 {-# INLINE thenCmp #-}
662 thenCmp EQ ordering = ordering
663 thenCmp ordering _ = ordering
665 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
666 eqListBy _ [] [] = True
667 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
668 eqListBy _ _ _ = False
670 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
671 -- `cmpList' uses a user-specified comparer
676 cmpList cmp (a:as) (b:bs)
677 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
681 removeSpaces :: String -> String
682 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
685 %************************************************************************
687 \subsection{Edit distance}
689 %************************************************************************
692 -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.
693 -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).
694 -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation
695 restrictedDamerauLevenshteinDistance :: String -> String -> Int
696 restrictedDamerauLevenshteinDistance str1 str2 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
701 restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int
702 restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
703 | m <= n = if n <= 32 -- n must be larger so this check is sufficient
704 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2
705 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2
706 | otherwise = if m <= 32 -- m must be larger so this check is sufficient
707 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1
708 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1
710 restrictedDamerauLevenshteinDistance' :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int
711 restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
713 | otherwise = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2
714 where m_ones@vector_mask = (2 ^ m) - 1
715 top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy
716 extractAnswer (_, _, _, _, distance) = distance
718 restrictedDamerauLevenshteinDistanceWorker :: (Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
719 restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2
720 = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ seq pm' $ seq d0' $ seq vp' $ seq vn' $ seq distance'' $ seq char2 $ (pm', d0', vp', vn', distance'')
722 pm' = IM.findWithDefault 0 (ord char2) str1_mvs
724 d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) -- No need to mask the shiftL because of the restricted range of pm
725 .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn
726 hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)
729 hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask
730 hn'_shift = (hn' `shiftL` 1) .&. vector_mask
731 vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)
732 vn' = d0' .&. hp'_shift
734 distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance
735 distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
737 sizedComplement :: Bits bv => bv -> bv -> bv
738 sizedComplement vector_mask vect = vector_mask `xor` vect
740 matchVectors :: Bits bv => String -> IM.IntMap bv
741 matchVectors = snd . foldl' go (0 :: Int, IM.empty)
743 go (ix, im) char = let ix' = ix + 1
744 im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im
745 in seq ix' $ seq im' $ (ix', im')
747 #ifdef __GLASGOW_HASKELL__
748 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-}
749 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-}
751 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-}
752 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-}
754 {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}
755 {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}
757 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}
758 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}
761 -- | Search for possible matches to the users input in the given list, returning a small number of ranked results
762 fuzzyMatch :: String -> [String] -> [String]
763 fuzzyMatch user_entered possibilites = map fst $ take mAX_RESULTS $ sortBy (comparing snd)
764 [ (poss, distance) | poss <- possibilites
765 , let distance = restrictedDamerauLevenshteinDistance poss user_entered
766 , distance <= fuzzy_threshold ]
767 where -- Work out an approriate match threshold (about a quarter of the # of characters the user entered)
768 fuzzy_threshold = max (round $ fromInteger (genericLength user_entered) / (4 :: Rational)) 1
772 %************************************************************************
774 \subsection[Utils-pairs]{Pairs}
776 %************************************************************************
779 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
780 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
784 seqList :: [a] -> b -> b
786 seqList (x:xs) b = x `seq` seqList xs b
792 global :: a -> IORef a
793 global a = unsafePerformIO (newIORef a)
797 consIORef :: IORef [a] -> a -> IO ()
799 atomicModifyIORef var (\xs -> (x:xs,()))
803 globalMVar :: a -> MVar a
804 globalMVar a = unsafePerformIO (newMVar a)
806 globalEmptyMVar :: MVar a
807 globalEmptyMVar = unsafePerformIO newEmptyMVar
813 looksLikeModuleName :: String -> Bool
814 looksLikeModuleName [] = False
815 looksLikeModuleName (c:cs) = isUpper c && go cs
817 go ('.':cs) = looksLikeModuleName cs
818 go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs
821 Akin to @Prelude.words@, but acts like the Bourne shell, treating
822 quoted strings as Haskell Strings, and also parses Haskell [String]
826 getCmd :: String -> Either String -- Error
827 (String, String) -- (Cmd, Rest)
828 getCmd s = case break isSpace $ dropWhile isSpace s of
829 ([], _) -> Left ("Couldn't find command in " ++ show s)
832 toCmdArgs :: String -> Either String -- Error
833 (String, [String]) -- (Cmd, Args)
834 toCmdArgs s = case getCmd s of
836 Right (cmd, s') -> case toArgs s' of
838 Right args -> Right (cmd, args)
840 toArgs :: String -> Either String -- Error
843 = case dropWhile isSpace str of
844 s@('[':_) -> case reads s of
846 | all isSpace spaces ->
849 Left ("Couldn't read " ++ show str ++ "as [String]")
852 toArgs' s = case dropWhile isSpace s of
854 ('"' : _) -> case reads s of
856 -- rest must either be [] or start with a space
857 | all isSpace (take 1 rest) ->
860 Right args -> Right (arg : args)
862 Left ("Couldn't read " ++ show s ++ "as String")
863 s' -> case break isSpace s' of
864 (arg, s'') -> case toArgs' s'' of
866 Right args -> Right (arg : args)
869 -- -----------------------------------------------------------------------------
873 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
874 readRational__ r = do
877 return ((n%1)*10^^(k-d), t)
880 (ds,s) <- lexDecDigits r
881 (ds',t) <- lexDotDigits s
882 return (read (ds++ds'), length ds', t)
884 readExp (e:s) | e `elem` "eE" = readExp' s
885 readExp s = return (0,s)
887 readExp' ('+':s) = readDec s
888 readExp' ('-':s) = do (k,t) <- readDec s
890 readExp' s = readDec s
893 (ds,r) <- nonnull isDigit s
894 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
897 lexDecDigits = nonnull isDigit
899 lexDotDigits ('.':s) = return (span isDigit s)
900 lexDotDigits s = return ("",s)
902 nonnull p s = do (cs@(_:_),t) <- return (span p s)
905 readRational :: String -> Rational -- NB: *does* handle a leading "-"
908 '-' : xs -> - (read_me xs)
912 = case (do { (x,"") <- readRational__ s ; return x }) of
914 [] -> error ("readRational: no parse:" ++ top_s)
915 _ -> error ("readRational: ambiguous parse:" ++ top_s)
918 -----------------------------------------------------------------------------
919 -- Create a hierarchy of directories
921 createDirectoryHierarchy :: FilePath -> IO ()
922 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
923 createDirectoryHierarchy dir = do
924 b <- doesDirectoryExist dir
925 unless b $ do createDirectoryHierarchy (takeDirectory dir)
928 -----------------------------------------------------------------------------
929 -- Verify that the 'dirname' portion of a FilePath exists.
931 doesDirNameExist :: FilePath -> IO Bool
932 doesDirNameExist fpath = case takeDirectory fpath of
933 "" -> return True -- XXX Hack
934 _ -> doesDirectoryExist (takeDirectory fpath)
936 -- --------------------------------------------------------------
937 -- check existence & modification time at the same time
939 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
940 modificationTimeIfExists f = do
941 (do t <- getModificationTime f; return (Just t))
942 `IO.catch` \e -> if isDoesNotExistError e
946 -- split a string at the last character where 'pred' is True,
947 -- returning a pair of strings. The first component holds the string
948 -- up (but not including) the last character for which 'pred' returned
949 -- True, the second whatever comes after (but also not including the
952 -- If 'pred' returns False for all characters in the string, the original
953 -- string is returned in the first component (and the second one is just
955 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
956 splitLongestPrefix str pred
957 | null r_pre = (str, [])
958 | otherwise = (reverse (tail r_pre), reverse r_suf)
959 -- 'tail' drops the char satisfying 'pred'
960 where (r_suf, r_pre) = break pred (reverse str)
962 escapeSpaces :: String -> String
963 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
967 --------------------------------------------------------------
969 --------------------------------------------------------------
971 -- | The function splits the given string to substrings
972 -- using the 'searchPathSeparator'.
973 parseSearchPath :: String -> [FilePath]
974 parseSearchPath path = split path
976 split :: String -> [String]
980 _:rest -> chunk : split rest
984 #ifdef mingw32_HOST_OS
985 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
989 (chunk', rest') = break isSearchPathSeparator s
991 data Direction = Forwards | Backwards
993 reslash :: Direction -> FilePath -> FilePath
995 where f ('/' : xs) = slash : f xs
996 f ('\\' : xs) = slash : f xs
997 f (x : xs) = x : f xs
1004 %************************************************************************
1006 \subsection[Utils-Data]{Utils for defining Data instances}
1008 %************************************************************************
1010 These functions helps us to define Data instances for abstract types.
1013 abstractConstr :: String -> Constr
1014 abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
1018 abstractDataType :: String -> DataType
1019 abstractDataType n = mkDataType n [abstractConstr n]
1023 -- Old GHC versions come with a base library with this function misspelled.
1024 #if __GLASGOW_HASKELL__ < 612
1025 mkNoRepType :: String -> DataType
1026 mkNoRepType = mkNorepType