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,
52 fuzzyMatch, fuzzyLookup,
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,
86 -- * Utils for printing C code
90 #include "HsVersions.h"
96 import Data.IORef ( IORef, newIORef, atomicModifyIORef )
97 import System.IO.Unsafe ( unsafePerformIO )
98 import Data.List hiding (group)
99 import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
105 import Control.Monad ( unless )
106 import System.IO.Error as IO ( isDoesNotExistError )
107 import System.Directory ( doesDirectoryExist, createDirectory,
108 getModificationTime )
109 import System.FilePath
110 import System.Time ( ClockTime )
112 import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit )
113 import Data.Ratio ( (%) )
114 import Data.Ord ( comparing )
117 import qualified Data.IntMap as IM
122 %************************************************************************
124 \subsection{Is DEBUG on, are we on Windows, etc?}
126 %************************************************************************
128 These booleans are global constants, set by CPP flags. They allow us to
129 recompile a single module (this one) to change whether or not debug output
130 appears. They sometimes let us avoid even running CPP elsewhere.
132 It's important that the flags are literal constants (True/False). Then,
133 with -0, tests of the flags in other modules will simplify to the correct
134 branch of the conditional, thereby dropping debug code altogether when
138 ghciSupported :: Bool
142 ghciSupported = False
152 ghciTablesNextToCode :: Bool
153 #ifdef GHCI_TABLES_NEXT_TO_CODE
154 ghciTablesNextToCode = True
156 ghciTablesNextToCode = False
159 isDynamicGhcLib :: Bool
161 isDynamicGhcLib = True
163 isDynamicGhcLib = False
166 isWindowsHost :: Bool
167 #ifdef mingw32_HOST_OS
170 isWindowsHost = False
173 isWindowsTarget :: Bool
174 #ifdef mingw32_TARGET_OS
175 isWindowsTarget = True
177 isWindowsTarget = False
180 isDarwinTarget :: Bool
181 #ifdef darwin_TARGET_OS
182 isDarwinTarget = True
184 isDarwinTarget = False
188 %************************************************************************
190 \subsection{A for loop}
192 %************************************************************************
195 -- | Compose a function with itself n times. (nth rather than twice)
196 nTimes :: Int -> (a -> a) -> (a -> a)
199 nTimes n f = f . nTimes (n-1) f
203 fstOf3 :: (a,b,c) -> a
204 sndOf3 :: (a,b,c) -> b
205 thirdOf3 :: (a,b,c) -> c
211 %************************************************************************
213 \subsection[Utils-lists]{General list processing}
215 %************************************************************************
218 filterOut :: (a->Bool) -> [a] -> [a]
219 -- ^ Like filter, only it reverses the sense of the test
221 filterOut p (x:xs) | p x = filterOut p xs
222 | otherwise = x : filterOut p xs
224 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
225 -- ^ Uses a function to determine which of two output lists an input element should join
226 partitionWith _ [] = ([],[])
227 partitionWith f (x:xs) = case f x of
229 Right c -> (bs, c:cs)
230 where (bs,cs) = partitionWith f xs
232 splitEithers :: [Either a b] -> ([a], [b])
233 -- ^ Teases a list of 'Either's apart into two lists
234 splitEithers [] = ([],[])
235 splitEithers (e : es) = case e of
237 Right y -> (xs, y:ys)
238 where (xs,ys) = splitEithers es
241 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
242 are of equal length. Alastair Reid thinks this should only happen if
243 DEBUGging on; hey, why not?
246 zipEqual :: String -> [a] -> [b] -> [(a,b)]
247 zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
248 zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
249 zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
253 zipWithEqual _ = zipWith
254 zipWith3Equal _ = zipWith3
255 zipWith4Equal _ = zipWith4
257 zipEqual _ [] [] = []
258 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
259 zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg)
261 zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
262 zipWithEqual _ _ [] [] = []
263 zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
265 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
266 = z a b c : zipWith3Equal msg z as bs cs
267 zipWith3Equal _ _ [] [] [] = []
268 zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
270 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
271 = z a b c d : zipWith4Equal msg z as bs cs ds
272 zipWith4Equal _ _ [] [] [] [] = []
273 zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
278 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
279 zipLazy :: [a] -> [b] -> [(a,b)]
281 -- We want to write this, but with GHC 6.4 we get a warning, so it
283 -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
284 -- so we write this instead:
285 zipLazy (x:xs) zs = let y : ys = zs
286 in (x,y) : zipLazy xs ys
291 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
292 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
293 -- the places where @p@ returns @True@
295 stretchZipWith _ _ _ [] _ = []
296 stretchZipWith p z f (x:xs) ys
297 | p x = f x z : stretchZipWith p z f xs ys
298 | otherwise = case ys of
300 (y:ys) -> f x y : stretchZipWith p z f xs ys
305 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
306 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
308 mapFst f xys = [(f x, y) | (x,y) <- xys]
309 mapSnd f xys = [(x, f y) | (x,y) <- xys]
311 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
313 mapAndUnzip _ [] = ([], [])
316 (rs1, rs2) = mapAndUnzip f xs
320 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
322 mapAndUnzip3 _ [] = ([], [], [])
323 mapAndUnzip3 f (x:xs)
324 = let (r1, r2, r3) = f x
325 (rs1, rs2, rs3) = mapAndUnzip3 f xs
327 (r1:rs1, r2:rs2, r3:rs3)
331 nOfThem :: Int -> a -> [a]
332 nOfThem n thing = replicate n thing
334 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
337 -- atLength atLenPred atEndPred ls n
338 -- | n < 0 = atLenPred n
339 -- | length ls < n = atEndPred (n - length ls)
340 -- | otherwise = atLenPred (drop n ls)
342 atLength :: ([a] -> b)
347 atLength atLenPred atEndPred ls n
348 | n < 0 = atEndPred n
349 | otherwise = go n ls
351 go n [] = atEndPred n
352 go 0 ls = atLenPred ls
353 go n (_:xs) = go (n-1) xs
355 -- Some special cases of atLength:
357 lengthExceeds :: [a] -> Int -> Bool
358 -- ^ > (lengthExceeds xs n) = (length xs > n)
359 lengthExceeds = atLength notNull (const False)
361 lengthAtLeast :: [a] -> Int -> Bool
362 lengthAtLeast = atLength notNull (== 0)
364 lengthIs :: [a] -> Int -> Bool
365 lengthIs = atLength null (==0)
367 listLengthCmp :: [a] -> Int -> Ordering
368 listLengthCmp = atLength atLen atEnd
372 | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
378 equalLength :: [a] -> [b] -> Bool
379 equalLength [] [] = True
380 equalLength (_:xs) (_:ys) = equalLength xs ys
381 equalLength _ _ = False
383 compareLength :: [a] -> [b] -> Ordering
384 compareLength [] [] = EQ
385 compareLength (_:xs) (_:ys) = compareLength xs ys
386 compareLength [] _ = LT
387 compareLength _ [] = GT
389 ----------------------------
390 singleton :: a -> [a]
393 isSingleton :: [a] -> Bool
394 isSingleton [_] = True
395 isSingleton _ = False
397 notNull :: [a] -> Bool
407 only _ = panic "Util: only"
410 Debugging/specialising versions of \tr{elem} and \tr{notElem}
413 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
416 isIn _msg x ys = x `elem` ys
417 isn'tIn _msg x ys = x `notElem` ys
421 = elem100 (_ILIT(0)) x ys
423 elem100 _ _ [] = False
425 | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
427 | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys
430 = notElem100 (_ILIT(0)) x ys
432 notElem100 _ _ [] = True
433 notElem100 i x (y:ys)
434 | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
436 | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys
440 %************************************************************************
442 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
444 %************************************************************************
447 Date: Mon, 3 May 93 20:45:23 +0200
448 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
449 To: partain@dcs.gla.ac.uk
450 Subject: natural merge sort beats quick sort [ and it is prettier ]
452 Here is a piece of Haskell code that I'm rather fond of. See it as an
453 attempt to get rid of the ridiculous quick-sort routine. group is
454 quite useful by itself I think it was John's idea originally though I
455 believe the lazy version is due to me [surprisingly complicated].
456 gamma [used to be called] is called gamma because I got inspired by
457 the Gamma calculus. It is not very close to the calculus but does
458 behave less sequentially than both foldr and foldl. One could imagine
459 a version of gamma that took a unit element as well thereby avoiding
460 the problem with empty lists.
462 I've tried this code against
464 1) insertion sort - as provided by haskell
465 2) the normal implementation of quick sort
466 3) a deforested version of quick sort due to Jan Sparud
467 4) a super-optimized-quick-sort of Lennart's
469 If the list is partially sorted both merge sort and in particular
470 natural merge sort wins. If the list is random [ average length of
471 rising subsequences = approx 2 ] mergesort still wins and natural
472 merge sort is marginally beaten by Lennart's soqs. The space
473 consumption of merge sort is a bit worse than Lennart's quick sort
474 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
475 fpca article ] isn't used because of group.
482 group :: (a -> a -> Bool) -> [a] -> [[a]]
483 -- Given a <= function, group finds maximal contiguous up-runs
484 -- or down-runs in the input list.
485 -- It's stable, in the sense that it never re-orders equal elements
487 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
488 -- From: Andy Gill <andy@dcs.gla.ac.uk>
489 -- Here is a `better' definition of group.
492 group p (x:xs) = group' xs x x (x :)
494 group' [] _ _ s = [s []]
495 group' (x:xs) x_min x_max s
496 | x_max `p` x = group' xs x_min x (s . (x :))
497 | not (x_min `p` x) = group' xs x x_max ((x :) . s)
498 | otherwise = s [] : group' xs x x (x :)
499 -- NB: the 'not' is essential for stablity
500 -- x `p` x_min would reverse equal elements
502 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
503 generalMerge _ xs [] = xs
504 generalMerge _ [] ys = ys
505 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
506 | otherwise = y : generalMerge p (x:xs) ys
508 -- gamma is now called balancedFold
510 balancedFold :: (a -> a -> a) -> [a] -> a
511 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
512 balancedFold _ [x] = x
513 balancedFold f l = balancedFold f (balancedFold' f l)
515 balancedFold' :: (a -> a -> a) -> [a] -> [a]
516 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
517 balancedFold' _ xs = xs
519 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
520 generalNaturalMergeSort _ [] = []
521 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
524 generalMergeSort p [] = []
525 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
527 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
529 mergeSort = generalMergeSort (<=)
530 naturalMergeSort = generalNaturalMergeSort (<=)
532 mergeSortLe le = generalMergeSort le
535 sortLe :: (a->a->Bool) -> [a] -> [a]
536 sortLe le = generalNaturalMergeSort le
538 sortWith :: Ord b => (a->b) -> [a] -> [a]
539 sortWith get_key xs = sortLe le xs
541 x `le` y = get_key x < get_key y
543 on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
544 on cmp sel = \x y -> sel x `cmp` sel y
548 %************************************************************************
550 \subsection[Utils-transitive-closure]{Transitive closure}
552 %************************************************************************
554 This algorithm for transitive closure is straightforward, albeit quadratic.
557 transitiveClosure :: (a -> [a]) -- Successor function
558 -> (a -> a -> Bool) -- Equality predicate
560 -> [a] -- The transitive closure
562 transitiveClosure succ eq xs
566 go done (x:xs) | x `is_in` done = go done xs
567 | otherwise = go (x:done) (succ x ++ xs)
570 x `is_in` (y:ys) | eq x y = True
571 | otherwise = x `is_in` ys
574 %************************************************************************
576 \subsection[Utils-accum]{Accumulating}
578 %************************************************************************
580 A combination of foldl with zip. It works with equal length lists.
583 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
585 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
586 foldl2 _ _ _ _ = panic "Util: foldl2"
588 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
589 -- True if the lists are the same length, and
590 -- all corresponding elements satisfy the predicate
592 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
596 Count the number of times a predicate is true
599 count :: (a -> Bool) -> [a] -> Int
601 count p (x:xs) | p x = 1 + count p xs
602 | otherwise = count p xs
605 @splitAt@, @take@, and @drop@ but with length of another
606 list giving the break-off point:
609 takeList :: [b] -> [a] -> [a]
614 (y:ys) -> y : takeList xs ys
616 dropList :: [b] -> [a] -> [a]
618 dropList _ xs@[] = xs
619 dropList (_:xs) (_:ys) = dropList xs ys
622 splitAtList :: [b] -> [a] -> ([a], [a])
623 splitAtList [] xs = ([], xs)
624 splitAtList _ xs@[] = (xs, xs)
625 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
627 (ys', ys'') = splitAtList xs ys
629 -- drop from the end of a list
630 dropTail :: Int -> [a] -> [a]
631 dropTail n = reverse . drop n . reverse
633 snocView :: [a] -> Maybe ([a],a)
634 -- Split off the last element
635 snocView [] = Nothing
636 snocView xs = go [] xs
638 -- Invariant: second arg is non-empty
639 go acc [x] = Just (reverse acc, x)
640 go acc (x:xs) = go (x:acc) xs
641 go _ [] = panic "Util: snocView"
643 split :: Char -> String -> [String]
644 split c s = case rest of
646 _:rest -> chunk : split c rest
647 where (chunk, rest) = break (==c) s
651 %************************************************************************
653 \subsection[Utils-comparison]{Comparisons}
655 %************************************************************************
658 isEqual :: Ordering -> Bool
659 -- Often used in (isEqual (a `compare` b))
664 thenCmp :: Ordering -> Ordering -> Ordering
665 {-# INLINE thenCmp #-}
666 thenCmp EQ ordering = ordering
667 thenCmp ordering _ = ordering
669 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
670 eqListBy _ [] [] = True
671 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
672 eqListBy _ _ _ = False
674 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
675 -- `cmpList' uses a user-specified comparer
680 cmpList cmp (a:as) (b:bs)
681 = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
685 removeSpaces :: String -> String
686 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
689 %************************************************************************
691 \subsection{Edit distance}
693 %************************************************************************
696 -- | Find the "restricted" Damerau-Levenshtein edit distance between two strings.
697 -- See: <http://en.wikipedia.org/wiki/Damerau-Levenshtein_distance>.
698 -- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing
699 -- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro).
700 -- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and
701 -- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation
702 restrictedDamerauLevenshteinDistance :: String -> String -> Int
703 restrictedDamerauLevenshteinDistance str1 str2
704 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
709 restrictedDamerauLevenshteinDistanceWithLengths
710 :: Int -> Int -> String -> String -> Int
711 restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2
713 = if n <= 32 -- n must be larger so this check is sufficient
714 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2
715 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2
718 = if m <= 32 -- m must be larger so this check is sufficient
719 then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1
720 else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1
722 restrictedDamerauLevenshteinDistance'
723 :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int
724 restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2
726 | otherwise = extractAnswer $
727 foldl' (restrictedDamerauLevenshteinDistanceWorker
728 (matchVectors str1) top_bit_mask vector_mask)
729 (0, 0, m_ones, 0, m) str2
731 m_ones@vector_mask = (2 ^ m) - 1
732 top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy
733 extractAnswer (_, _, _, _, distance) = distance
735 restrictedDamerauLevenshteinDistanceWorker
736 :: (Bits bv) => IM.IntMap bv -> bv -> bv
737 -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int)
738 restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask
739 (pm, d0, vp, vn, distance) char2
740 = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $
741 seq pm' $ seq d0' $ seq vp' $ seq vn' $
742 seq distance'' $ seq char2 $
743 (pm', d0', vp', vn', distance'')
745 pm' = IM.findWithDefault 0 (ord char2) str1_mvs
747 d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm)
748 .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn
749 -- No need to mask the shiftL because of the restricted range of pm
751 hp' = vn .|. sizedComplement vector_mask (d0' .|. vp)
754 hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask
755 hn'_shift = (hn' `shiftL` 1) .&. vector_mask
756 vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift)
757 vn' = d0' .&. hp'_shift
759 distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance
760 distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance'
762 sizedComplement :: Bits bv => bv -> bv -> bv
763 sizedComplement vector_mask vect = vector_mask `xor` vect
765 matchVectors :: Bits bv => String -> IM.IntMap bv
766 matchVectors = snd . foldl' go (0 :: Int, IM.empty)
768 go (ix, im) char = let ix' = ix + 1
769 im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im
770 in seq ix' $ seq im' $ (ix', im')
772 #ifdef __GLASGOW_HASKELL__
773 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
774 :: Word32 -> Int -> Int -> String -> String -> Int #-}
775 {-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance'
776 :: Integer -> Int -> Int -> String -> String -> Int #-}
778 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
779 :: IM.IntMap Word32 -> Word32 -> Word32
780 -> (Word32, Word32, Word32, Word32, Int)
781 -> Char -> (Word32, Word32, Word32, Word32, Int) #-}
782 {-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker
783 :: IM.IntMap Integer -> Integer -> Integer
784 -> (Integer, Integer, Integer, Integer, Int)
785 -> Char -> (Integer, Integer, Integer, Integer, Int) #-}
787 {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-}
788 {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-}
790 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-}
791 {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-}
794 fuzzyMatch :: String -> [String] -> [String]
795 fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals]
797 -- | Search for possible matches to the users input in the given list,
798 -- returning a small number of ranked results
799 fuzzyLookup :: String -> [(String,a)] -> [a]
800 fuzzyLookup user_entered possibilites
801 = map fst $ take mAX_RESULTS $ sortBy (comparing snd)
802 [ (poss_val, distance) | (poss_str, poss_val) <- possibilites
803 , let distance = restrictedDamerauLevenshteinDistance
804 poss_str user_entered
805 , distance <= fuzzy_threshold ]
807 -- Work out an approriate match threshold:
808 -- We report a candidate if its edit distance is <= the threshold,
809 -- The threshhold is set to about a quarter of the # of characters the user entered
811 -- 1 0 -- Don't suggest *any* candidates
812 -- 2 1 -- for single-char identifiers
818 fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational)
822 %************************************************************************
824 \subsection[Utils-pairs]{Pairs}
826 %************************************************************************
829 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
830 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
834 seqList :: [a] -> b -> b
836 seqList (x:xs) b = x `seq` seqList xs b
842 global :: a -> IORef a
843 global a = unsafePerformIO (newIORef a)
847 consIORef :: IORef [a] -> a -> IO ()
849 atomicModifyIORef var (\xs -> (x:xs,()))
853 globalMVar :: a -> MVar a
854 globalMVar a = unsafePerformIO (newMVar a)
856 globalEmptyMVar :: MVar a
857 globalEmptyMVar = unsafePerformIO newEmptyMVar
863 looksLikeModuleName :: String -> Bool
864 looksLikeModuleName [] = False
865 looksLikeModuleName (c:cs) = isUpper c && go cs
867 go ('.':cs) = looksLikeModuleName cs
868 go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs
871 Akin to @Prelude.words@, but acts like the Bourne shell, treating
872 quoted strings as Haskell Strings, and also parses Haskell [String]
876 getCmd :: String -> Either String -- Error
877 (String, String) -- (Cmd, Rest)
878 getCmd s = case break isSpace $ dropWhile isSpace s of
879 ([], _) -> Left ("Couldn't find command in " ++ show s)
882 toCmdArgs :: String -> Either String -- Error
883 (String, [String]) -- (Cmd, Args)
884 toCmdArgs s = case getCmd s of
886 Right (cmd, s') -> case toArgs s' of
888 Right args -> Right (cmd, args)
890 toArgs :: String -> Either String -- Error
893 = case dropWhile isSpace str of
894 s@('[':_) -> case reads s of
896 | all isSpace spaces ->
899 Left ("Couldn't read " ++ show str ++ "as [String]")
902 toArgs' s = case dropWhile isSpace s of
904 ('"' : _) -> case reads s of
906 -- rest must either be [] or start with a space
907 | all isSpace (take 1 rest) ->
910 Right args -> Right (arg : args)
912 Left ("Couldn't read " ++ show s ++ "as String")
913 s' -> case break isSpace s' of
914 (arg, s'') -> case toArgs' s'' of
916 Right args -> Right (arg : args)
919 -- -----------------------------------------------------------------------------
923 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
924 readRational__ r = do
927 return ((n%1)*10^^(k-d), t)
930 (ds,s) <- lexDecDigits r
931 (ds',t) <- lexDotDigits s
932 return (read (ds++ds'), length ds', t)
934 readExp (e:s) | e `elem` "eE" = readExp' s
935 readExp s = return (0,s)
937 readExp' ('+':s) = readDec s
938 readExp' ('-':s) = do (k,t) <- readDec s
940 readExp' s = readDec s
943 (ds,r) <- nonnull isDigit s
944 return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
947 lexDecDigits = nonnull isDigit
949 lexDotDigits ('.':s) = return (span isDigit s)
950 lexDotDigits s = return ("",s)
952 nonnull p s = do (cs@(_:_),t) <- return (span p s)
955 readRational :: String -> Rational -- NB: *does* handle a leading "-"
958 '-' : xs -> - (read_me xs)
962 = case (do { (x,"") <- readRational__ s ; return x }) of
964 [] -> error ("readRational: no parse:" ++ top_s)
965 _ -> error ("readRational: ambiguous parse:" ++ top_s)
968 -----------------------------------------------------------------------------
969 -- Create a hierarchy of directories
971 createDirectoryHierarchy :: FilePath -> IO ()
972 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
973 createDirectoryHierarchy dir = do
974 b <- doesDirectoryExist dir
975 unless b $ do createDirectoryHierarchy (takeDirectory dir)
978 -----------------------------------------------------------------------------
979 -- Verify that the 'dirname' portion of a FilePath exists.
981 doesDirNameExist :: FilePath -> IO Bool
982 doesDirNameExist fpath = case takeDirectory fpath of
983 "" -> return True -- XXX Hack
984 _ -> doesDirectoryExist (takeDirectory fpath)
986 -- --------------------------------------------------------------
987 -- check existence & modification time at the same time
989 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
990 modificationTimeIfExists f = do
991 (do t <- getModificationTime f; return (Just t))
992 `catchIO` \e -> if isDoesNotExistError e
996 -- split a string at the last character where 'pred' is True,
997 -- returning a pair of strings. The first component holds the string
998 -- up (but not including) the last character for which 'pred' returned
999 -- True, the second whatever comes after (but also not including the
1002 -- If 'pred' returns False for all characters in the string, the original
1003 -- string is returned in the first component (and the second one is just
1005 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
1006 splitLongestPrefix str pred
1007 | null r_pre = (str, [])
1008 | otherwise = (reverse (tail r_pre), reverse r_suf)
1009 -- 'tail' drops the char satisfying 'pred'
1010 where (r_suf, r_pre) = break pred (reverse str)
1012 escapeSpaces :: String -> String
1013 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
1015 type Suffix = String
1017 --------------------------------------------------------------
1019 --------------------------------------------------------------
1021 -- | The function splits the given string to substrings
1022 -- using the 'searchPathSeparator'.
1023 parseSearchPath :: String -> [FilePath]
1024 parseSearchPath path = split path
1026 split :: String -> [String]
1030 _:rest -> chunk : split rest
1034 #ifdef mingw32_HOST_OS
1035 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1039 (chunk', rest') = break isSearchPathSeparator s
1041 data Direction = Forwards | Backwards
1043 reslash :: Direction -> FilePath -> FilePath
1045 where f ('/' : xs) = slash : f xs
1046 f ('\\' : xs) = slash : f xs
1047 f (x : xs) = x : f xs
1054 %************************************************************************
1056 \subsection[Utils-Data]{Utils for defining Data instances}
1058 %************************************************************************
1060 These functions helps us to define Data instances for abstract types.
1063 abstractConstr :: String -> Constr
1064 abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
1068 abstractDataType :: String -> DataType
1069 abstractDataType n = mkDataType n [abstractConstr n]
1072 %************************************************************************
1074 \subsection[Utils-C]{Utils for printing C code}
1076 %************************************************************************
1079 charToC :: Word8 -> String
1081 case chr (fromIntegral w) of
1085 c | c >= ' ' && c <= '~' -> [c]
1086 | otherwise -> ['\\',
1087 chr (ord '0' + ord c `div` 64),
1088 chr (ord '0' + ord c `div` 8 `mod` 8),
1089 chr (ord '0' + ord c `mod` 8)]