X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=ec5070f26a637a838a9d8c86b881a9ab23b85b84;hp=39fd64b679dafb6d36b68fee8f5620dcfdab1fca;hb=00022894bbb2dfa33fd213eedbac0f28b4c4b7b4;hpb=317fc69d18eda68fd65f5ba634feafbe4a3923da diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 39fd64b..ec5070f 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -2,188 +2,236 @@ % (c) The University of Glasgow 2006 % (c) The University of Glasgow 1992-2002 % -\section[Util]{Highly random utility functions} \begin{code} +-- | Highly random utility functions module Util ( + -- * Flags dependent on the compiler build + ghciSupported, debugIsOn, ghciTablesNextToCode, isDynamicGhcLib, + isWindowsHost, isWindowsTarget, isDarwinTarget, - -- general list processing - zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + -- * General list processing + zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, - mapFst, mapSnd, - mapAndUnzip, mapAndUnzip3, - nOfThem, filterOut, partitionWith, splitEithers, + + unzipWith, + + mapFst, mapSnd, + mapAndUnzip, mapAndUnzip3, + nOfThem, filterOut, partitionWith, splitEithers, + + foldl1', foldl2, count, all2, - lengthExceeds, lengthIs, lengthAtLeast, - listLengthCmp, atLength, equalLength, compareLength, + lengthExceeds, lengthIs, lengthAtLeast, + listLengthCmp, atLength, equalLength, compareLength, - isSingleton, only, singleton, - notNull, snocView, + isSingleton, only, singleton, + notNull, snocView, - isIn, isn'tIn, + isIn, isn'tIn, - -- for-loop - nTimes, + -- * Tuples + fstOf3, sndOf3, thirdOf3, - -- sorting - sortLe, sortWith, + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, - -- transitive closures - transitiveClosure, + -- * For loop + nTimes, - -- accumulating - mapAccumL, mapAccumR, mapAccumB, - foldl2, count, all2, - - takeList, dropList, splitAtList, split, + -- * Sorting + sortLe, sortWith, on, - -- comparisons - isEqual, eqListBy, - thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch, - removeSpaces, + -- * Comparisons + isEqual, eqListBy, + thenCmp, cmpList, + removeSpaces, + + -- * Edit distance + fuzzyMatch, - -- strictness - foldl', seqList, + -- * Transitive closures + transitiveClosure, - -- pairs - unzipWith, + -- * Strictness + seqList, - global, consIORef, + -- * Module names + looksLikeModuleName, - -- module names - looksLikeModuleName, - - toArgs, + -- * Argument processing + getCmd, toCmdArgs, toArgs, - -- Floating point stuff - readRational, + -- * Floating point + readRational, - -- IO-ish utilities - createDirectoryHierarchy, - doesDirNameExist, - modificationTimeIfExists, + -- * IO-ish utilities + createDirectoryHierarchy, + doesDirNameExist, + modificationTimeIfExists, - later, handleDyn, handle, + global, consIORef, globalMVar, globalEmptyMVar, - -- Filename utils - Suffix, - splitFilename, suffixOf, basenameOf, joinFileExt, - splitFilenameDir, joinFileName, - splitFilename3, - splitLongestPrefix, - replaceFilenameSuffix, directoryOf, filenameOf, - replaceFilenameDirectory, - escapeSpaces, isPathSeparator, - parseSearchPath, - normalisePath, platformPath, pgmPath, + -- * Filenames and paths + Suffix, + splitLongestPrefix, + escapeSpaces, + parseSearchPath, + Direction(..), reslash, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType ) where #include "HsVersions.h" -import Panic ( panic, trace ) -import FastTypes - -import Control.Exception ( Exception(..), finally, catchDyn, throw ) -import qualified Control.Exception as Exception -import Data.Dynamic ( Typeable ) -import Data.IORef ( IORef, newIORef ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef ( readIORef, writeIORef ) +import Panic -import qualified Data.List as List ( elem, notElem ) +import Data.Data +import Data.IORef ( IORef, newIORef, atomicModifyIORef ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List hiding (group) +import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar ) -#ifndef DEBUG -import Data.List ( zipWith4 ) +#ifdef DEBUG +import FastTypes #endif -import Control.Monad ( when ) -import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError ) -import System.Directory ( doesDirectoryExist, createDirectory, +import Control.Monad ( unless ) +import System.IO.Error as IO ( catch, isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) -import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) -import Data.Ratio ( (%) ) -import System.Time ( ClockTime ) +import System.FilePath +import System.Time ( ClockTime ) + +import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Data.Ratio ( (%) ) +import Data.Ord ( comparing ) +import Data.Bits +import Data.Word +import qualified Data.IntMap as IM infixr 9 `thenCmp` \end{code} %************************************************************************ -%* * -\subsection{The Eager monad} -%* * +%* * +\subsection{Is DEBUG on, are we on Windows, etc?} +%* * %************************************************************************ -The @Eager@ monad is just an encoding of continuation-passing style, -used to allow you to express "do this and then that", mainly to avoid -space leaks. It's done with a type synonym to save bureaucracy. +These booleans are global constants, set by CPP flags. They allow us to +recompile a single module (this one) to change whether or not debug output +appears. They sometimes let us avoid even running CPP elsewhere. + +It's important that the flags are literal constants (True/False). Then, +with -0, tests of the flags in other modules will simplify to the correct +branch of the conditional, thereby dropping debug code altogether when +the flags are off. \begin{code} -#if NOT_USED +ghciSupported :: Bool +#ifdef GHCI +ghciSupported = True +#else +ghciSupported = False +#endif -type Eager ans a = (a -> ans) -> ans +debugIsOn :: Bool +#ifdef DEBUG +debugIsOn = True +#else +debugIsOn = False +#endif -runEager :: Eager a a -> a -runEager m = m (\x -> x) +ghciTablesNextToCode :: Bool +#ifdef GHCI_TABLES_NEXT_TO_CODE +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif -appEager :: Eager ans a -> (a -> ans) -> ans -appEager m cont = m cont +isDynamicGhcLib :: Bool +#ifdef DYNAMIC +isDynamicGhcLib = True +#else +isDynamicGhcLib = False +#endif -thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b -thenEager m k cont = m (\r -> k r cont) +isWindowsHost :: Bool +#ifdef mingw32_HOST_OS +isWindowsHost = True +#else +isWindowsHost = False +#endif -returnEager :: a -> Eager ans a -returnEager v cont = cont v +isWindowsTarget :: Bool +#ifdef mingw32_TARGET_OS +isWindowsTarget = True +#else +isWindowsTarget = False +#endif -mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b] -mapEager f [] = returnEager [] -mapEager f (x:xs) = f x `thenEager` \ y -> - mapEager f xs `thenEager` \ ys -> - returnEager (y:ys) +isDarwinTarget :: Bool +#ifdef darwin_TARGET_OS +isDarwinTarget = True +#else +isDarwinTarget = False #endif \end{code} %************************************************************************ -%* * +%* * \subsection{A for loop} -%* * +%* * %************************************************************************ \begin{code} --- Compose a function with itself n times. (nth rather than twice) +-- | Compose a function with itself n times. (nth rather than twice) nTimes :: Int -> (a -> a) -> (a -> a) nTimes 0 _ = id nTimes 1 f = f nTimes n f = f . nTimes (n-1) f \end{code} +\begin{code} +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thirdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thirdOf3 (_,_,c) = c +\end{code} + %************************************************************************ -%* * +%* * \subsection[Utils-lists]{General list processing} -%* * +%* * %************************************************************************ \begin{code} filterOut :: (a->Bool) -> [a] -> [a] --- Like filter, only reverses the sense of the test -filterOut p [] = [] +-- ^ Like filter, only it reverses the sense of the test +filterOut _ [] = [] filterOut p (x:xs) | p x = filterOut p xs - | otherwise = x : filterOut p xs + | otherwise = x : filterOut p xs partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) -partitionWith f [] = ([],[]) +-- ^ Uses a function to determine which of two output lists an input element should join +partitionWith _ [] = ([],[]) partitionWith f (x:xs) = case f x of - Left b -> (b:bs, cs) - Right c -> (bs, c:cs) - where - (bs,cs) = partitionWith f xs + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs splitEithers :: [Either a b] -> ([a], [b]) +-- ^ Teases a list of 'Either's apart into two lists splitEithers [] = ([],[]) splitEithers (e : es) = case e of - Left x -> (x:xs, ys) - Right y -> (xs, y:ys) - where - (xs,ys) = splitEithers es + Left x -> (x:xs, ys) + Right y -> (xs, y:ys) + where (xs,ys) = splitEithers es \end{code} A paranoid @zip@ (and some @zipWith@ friends) that checks the lists @@ -191,10 +239,10 @@ are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? \begin{code} -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipEqual :: String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #ifndef DEBUG zipEqual _ = zip @@ -202,46 +250,50 @@ zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 zipWith4Equal _ = zipWith4 #else -zipEqual msg [] [] = [] +zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs -zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg) +zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs -zipWithEqual msg _ [] [] = [] -zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) +zipWithEqual _ _ [] [] = [] +zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) zipWith3Equal msg z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3Equal msg z as bs cs -zipWith3Equal msg _ [] [] [] = [] -zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) + = z a b c : zipWith3Equal msg z as bs cs +zipWith3Equal _ _ [] [] [] = [] +zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4Equal msg z as bs cs ds -zipWith4Equal msg _ [] [] [] [] = [] -zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) + = z a b c d : zipWith4Equal msg z as bs cs ds +zipWith4Equal _ _ [] [] [] [] = [] +zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) #endif \end{code} \begin{code} --- zipLazy is lazy in the second list (observe the ~) - +-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] ys = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys +zipLazy [] _ = [] +-- We want to write this, but with GHC 6.4 we get a warning, so it +-- doesn't validate: +-- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys +-- so we write this instead: +zipLazy (x:xs) zs = let y : ys = zs + in (x,y) : zipLazy xs ys \end{code} \begin{code} stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] --- (stretchZipWith p z f xs ys) stretches ys by inserting z in --- the places where p returns *True* +-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in +-- the places where @p@ returns @True@ -stretchZipWith p z f [] ys = [] +stretchZipWith _ _ _ [] _ = [] stretchZipWith p z f (x:xs) ys | p x = f x z : stretchZipWith p z f xs ys | otherwise = case ys of - [] -> [] - (y:ys) -> f x y : stretchZipWith p z f xs ys + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys \end{code} @@ -254,21 +306,19 @@ mapSnd f xys = [(x, f y) | (x,y) <- xys] mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) -mapAndUnzip f [] = ([],[]) +mapAndUnzip _ [] = ([], []) mapAndUnzip f (x:xs) - = let - (r1, r2) = f x - (rs1, rs2) = mapAndUnzip f xs + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs in (r1:rs1, r2:rs2) mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) -mapAndUnzip3 f [] = ([],[],[]) +mapAndUnzip3 _ [] = ([], [], []) mapAndUnzip3 f (x:xs) - = let - (r1, r2, r3) = f x - (rs1, rs2, rs3) = mapAndUnzip3 f xs + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs in (r1:rs1, r2:rs2, r3:rs3) \end{code} @@ -277,30 +327,31 @@ mapAndUnzip3 f (x:xs) nOfThem :: Int -> a -> [a] nOfThem n thing = replicate n thing --- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n'; --- specification: +-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: -- +-- @ -- atLength atLenPred atEndPred ls n -- | n < 0 = atLenPred n -- | length ls < n = atEndPred (n - length ls) -- | otherwise = atLenPred (drop n ls) --- +-- @ atLength :: ([a] -> b) -> (Int -> b) -> [a] -> Int -> b -atLength atLenPred atEndPred ls n - | n < 0 = atEndPred n +atLength atLenPred atEndPred ls n + | n < 0 = atEndPred n | otherwise = go n ls where go n [] = atEndPred n go 0 ls = atLenPred ls go n (_:xs) = go (n-1) xs --- special cases. +-- Some special cases of atLength: + lengthExceeds :: [a] -> Int -> Bool --- (lengthExceeds xs n) = (length xs > n) +-- ^ > (lengthExceeds xs n) = (length xs > n) lengthExceeds = atLength notNull (const False) lengthAtLeast :: [a] -> Int -> Bool @@ -309,8 +360,8 @@ lengthAtLeast = atLength notNull (== 0) lengthIs :: [a] -> Int -> Bool lengthIs = atLength null (==0) -listLengthCmp :: [a] -> Int -> Ordering -listLengthCmp = atLength atLen atEnd +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd where atEnd 0 = EQ atEnd x @@ -321,23 +372,23 @@ listLengthCmp = atLength atLen atEnd atLen _ = GT equalLength :: [a] -> [b] -> Bool -equalLength [] [] = True +equalLength [] [] = True equalLength (_:xs) (_:ys) = equalLength xs ys -equalLength xs ys = False +equalLength _ _ = False compareLength :: [a] -> [b] -> Ordering -compareLength [] [] = EQ +compareLength [] [] = EQ compareLength (_:xs) (_:ys) = compareLength xs ys -compareLength [] _ys = LT -compareLength _xs [] = GT +compareLength [] _ = LT +compareLength _ [] = GT ---------------------------- singleton :: a -> [a] singleton x = [x] isSingleton :: [a] -> Bool -isSingleton [x] = True -isSingleton _ = False +isSingleton [_] = True +isSingleton _ = False notNull :: [a] -> Bool notNull [] = False @@ -349,49 +400,43 @@ only [a] = a #else only (a:_) = a #endif +only _ = panic "Util: only" \end{code} Debugging/specialising versions of \tr{elem} and \tr{notElem} \begin{code} -isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool +isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool # ifndef DEBUG -isIn msg x ys = elem__ x ys -isn'tIn msg x ys = notElem__ x ys - ---these are here to be SPECIALIZEd (automagically) -elem__ _ [] = False -elem__ x (y:ys) = x==y || elem__ x ys - -notElem__ x [] = True -notElem__ x (y:ys) = x /= y && notElem__ x ys +isIn _msg x ys = x `elem` ys +isn'tIn _msg x ys = x `notElem` ys # else /* DEBUG */ isIn msg x ys - = elem (_ILIT 0) x ys + = elem100 (_ILIT(0)) x ys where - elem i _ [] = False - elem i x (y:ys) - | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $ - x `List.elem` (y:ys) - | otherwise = x == y || elem (i +# _ILIT(1)) x ys + elem100 _ _ [] = False + elem100 i x (y:ys) + | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg) + (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i +# _ILIT(1)) x ys isn'tIn msg x ys - = notElem (_ILIT 0) x ys + = notElem100 (_ILIT(0)) x ys where - notElem i x [] = True - notElem i x (y:ys) - | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $ - x `List.notElem` (y:ys) - | otherwise = x /= y && notElem (i +# _ILIT(1)) x ys + notElem100 _ _ [] = True + notElem100 i x (y:ys) + | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg) + (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i +# _ILIT(1)) x ys # endif /* DEBUG */ \end{code} %************************************************************************ -%* * +%* * \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} -%* * +%* * %************************************************************************ \begin{display} @@ -431,7 +476,7 @@ Carsten \begin{code} group :: (a -> a -> Bool) -> [a] -> [[a]] --- Given a <= function, group finds maximal contiguous up-runs +-- Given a <= function, group finds maximal contiguous up-runs -- or down-runs in the input list. -- It's stable, in the sense that it never re-orders equal elements -- @@ -439,35 +484,36 @@ group :: (a -> a -> Bool) -> [a] -> [[a]] -- From: Andy Gill -- Here is a `better' definition of group. -group p [] = [] +group _ [] = [] group p (x:xs) = group' xs x x (x :) where group' [] _ _ s = [s []] - group' (x:xs) x_min x_max s - | x_max `p` x = group' xs x_min x (s . (x :)) - | not (x_min `p` x) = group' xs x x_max ((x :) . s) - | otherwise = s [] : group' xs x x (x :) - -- NB: the 'not' is essential for stablity - -- x `p` x_min would reverse equal elements + group' (x:xs) x_min x_max s + | x_max `p` x = group' xs x_min x (s . (x :)) + | not (x_min `p` x) = group' xs x x_max ((x :) . s) + | otherwise = s [] : group' xs x x (x :) + -- NB: the 'not' is essential for stablity + -- x `p` x_min would reverse equal elements generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] -generalMerge p xs [] = xs -generalMerge p [] ys = ys -generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) - | otherwise = y : generalMerge p (x:xs) ys +generalMerge _ xs [] = xs +generalMerge _ [] ys = ys +generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) + | otherwise = y : generalMerge p (x:xs) ys -- gamma is now called balancedFold balancedFold :: (a -> a -> a) -> [a] -> a -balancedFold f [] = error "can't reduce an empty list using balancedFold" -balancedFold f [x] = x +balancedFold _ [] = error "can't reduce an empty list using balancedFold" +balancedFold _ [x] = x balancedFold f l = balancedFold f (balancedFold' f l) balancedFold' :: (a -> a -> a) -> [a] -> [a] balancedFold' f (x:y:xs) = f x y : balancedFold' f xs -balancedFold' f xs = xs +balancedFold' _ xs = xs -generalNaturalMergeSort p [] = [] +generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a] +generalNaturalMergeSort _ [] = [] generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs #if NOT_USED @@ -488,129 +534,68 @@ sortLe le = generalNaturalMergeSort le sortWith :: Ord b => (a->b) -> [a] -> [a] sortWith get_key xs = sortLe le xs where - x `le` y = get_key x < get_key y + x `le` y = get_key x < get_key y + +on :: (a -> a -> c) -> (b -> a) -> b -> b -> c +on cmp sel = \x y -> sel x `cmp` sel y + \end{code} %************************************************************************ -%* * +%* * \subsection[Utils-transitive-closure]{Transitive closure} -%* * +%* * %************************************************************************ This algorithm for transitive closure is straightforward, albeit quadratic. \begin{code} -transitiveClosure :: (a -> [a]) -- Successor function - -> (a -> a -> Bool) -- Equality predicate - -> [a] - -> [a] -- The transitive closure +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure transitiveClosure succ eq xs = go [] xs where - go done [] = done + go done [] = done go done (x:xs) | x `is_in` done = go done xs - | otherwise = go (x:done) (succ x ++ xs) + | otherwise = go (x:done) (succ x ++ xs) - x `is_in` [] = False + _ `is_in` [] = False x `is_in` (y:ys) | eq x y = True - | otherwise = x `is_in` ys + | otherwise = x `is_in` ys \end{code} %************************************************************************ -%* * +%* * \subsection[Utils-accum]{Accumulating} -%* * +%* * %************************************************************************ -@mapAccumL@ behaves like a combination -of @map@ and @foldl@; -it applies a function to each element of a list, passing an accumulating -parameter from left to right, and returning a final value of this -accumulator together with the new list. - -\begin{code} -mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list - -mapAccumL f b [] = (b, []) -mapAccumL f b (x:xs) = (b'', x':xs') where - (b', x') = f b x - (b'', xs') = mapAccumL f b' xs -\end{code} - -@mapAccumR@ does the same, but working from right to left instead. Its type is -the same as @mapAccumL@, though. - -\begin{code} -mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list - -mapAccumR f b [] = (b, []) -mapAccumR f b (x:xs) = (b'', x':xs') where - (b'', x') = f b' x - (b', xs') = mapAccumR f b xs -\end{code} - -Here is the bi-directional version, that works from both left and right. - -\begin{code} -mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) - -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> accl -- Initial accumulator from left - -> accr -- Initial accumulator from right - -> [x] -- Input list - -> (accl, accr, [y]) -- Final accumulators and result list - -mapAccumB f a b [] = (a,b,[]) -mapAccumB f a b (x:xs) = (a'',b'',y:ys) - where - (a',b'',y) = f a b' x - (a'',b',ys) = mapAccumB f a' b xs -\end{code} - -A strict version of foldl. - -\begin{code} -foldl' :: (a -> b -> a) -> a -> [b] -> a -foldl' f z xs = lgo z xs - where - lgo z [] = z - lgo z (x:xs) = (lgo $! (f z x)) xs -\end{code} - A combination of foldl with zip. It works with equal length lists. \begin{code} foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc -foldl2 k z [] [] = z +foldl2 _ z [] [] = z foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs +foldl2 _ _ _ _ = panic "Util: foldl2" all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool --- True if the lists are the same length, and +-- True if the lists are the same length, and -- all corresponding elements satisfy the predicate -all2 p [] [] = True +all2 _ [] [] = True all2 p (x:xs) (y:ys) = p x y && all2 p xs ys -all2 p xs ys = False +all2 _ _ _ = False \end{code} Count the number of times a predicate is true \begin{code} count :: (a -> Bool) -> [a] -> Int -count p [] = 0 +count _ [] = 0 count p (x:xs) | p x = 1 + count p xs - | otherwise = count p xs + | otherwise = count p xs \end{code} @splitAt@, @take@, and @drop@ but with length of another @@ -619,7 +604,7 @@ list giving the break-off point: \begin{code} takeList :: [b] -> [a] -> [a] takeList [] _ = [] -takeList (_:xs) ls = +takeList (_:xs) ls = case ls of [] -> [] (y:ys) -> y : takeList xs ys @@ -637,27 +622,32 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys +-- drop from the end of a list +dropTail :: Int -> [a] -> [a] +dropTail n = reverse . drop n . reverse + snocView :: [a] -> Maybe ([a],a) - -- Split off the last element + -- Split off the last element snocView [] = Nothing snocView xs = go [] xs - where - -- Invariant: second arg is non-empty - go acc [x] = Just (reverse acc, x) - go acc (x:xs) = go (x:acc) xs + where + -- Invariant: second arg is non-empty + go acc [x] = Just (reverse acc, x) + go acc (x:xs) = go (x:acc) xs + go _ [] = panic "Util: snocView" split :: Char -> String -> [String] split c s = case rest of - [] -> [chunk] - _:rest -> chunk : split c rest + [] -> [chunk] + _:rest -> chunk : split c rest where (chunk, rest) = break (==c) s \end{code} %************************************************************************ -%* * +%* * \subsection[Utils-comparison]{Comparisons} -%* * +%* * %************************************************************************ \begin{code} @@ -669,76 +659,122 @@ isEqual LT = False thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} -thenCmp EQ any = any -thenCmp other any = other +thenCmp EQ ordering = ordering +thenCmp ordering _ = ordering eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy eq [] [] = True +eqListBy _ [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy eq xs ys = False +eqListBy _ _ _ = False cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer -cmpList cmp [] [] = EQ -cmpList cmp [] _ = LT -cmpList cmp _ [] = GT +cmpList _ [] [] = EQ +cmpList _ [] _ = LT +cmpList _ _ [] = GT cmpList cmp (a:as) (b:bs) = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } \end{code} \begin{code} -prefixMatch :: Eq a => [a] -> [a] -> Bool -prefixMatch [] _str = True -prefixMatch _pat [] = False -prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss - | otherwise = False - -maybePrefixMatch :: String -> String -> Maybe String -maybePrefixMatch [] rest = Just rest -maybePrefixMatch (_:_) [] = Nothing -maybePrefixMatch (p:pat) (r:rest) - | p == r = maybePrefixMatch pat rest - | otherwise = Nothing - -suffixMatch :: Eq a => [a] -> [a] -> Bool -suffixMatch pat str = prefixMatch (reverse pat) (reverse str) - removeSpaces :: String -> String removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace \end{code} %************************************************************************ -%* * -\subsection[Utils-pairs]{Pairs} -%* * +%* * +\subsection{Edit distance} +%* * %************************************************************************ -The following are curried versions of @fst@ and @snd@. - \begin{code} -#if NOT_USED -cfst :: a -> b -> a -- stranal-sem only (Note) -cfst x y = x -#endif -\end{code} +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. See: . +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +restrictedDamerauLevenshteinDistance :: String -> String -> Int +restrictedDamerauLevenshteinDistance str1 str2 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + where + m = length str1 + n = length str2 + +restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + | m <= n = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + | otherwise = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + +restrictedDamerauLevenshteinDistance' :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + | [] <- str1 = n + | otherwise = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2 + where m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker :: (Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2 + = 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'') + where + pm' = IM.findWithDefault 0 (ord char2) str1_mvs + + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) -- No need to mask the shiftL because of the restricted range of pm + .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) + hn' = d0' .&. vp + + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask + hn'_shift = (hn' `shiftL` 1) .&. vector_mask + vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) + vn' = d0' .&. hp'_shift + + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance + distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' + +sizedComplement :: Bits bv => bv -> bv -> bv +sizedComplement vector_mask vect = vector_mask `xor` vect + +matchVectors :: Bits bv => String -> IM.IntMap bv +matchVectors = snd . foldl' go (0 :: Int, IM.empty) + where + go (ix, im) char = let ix' = ix + 1 + im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im + in seq ix' $ seq im' $ (ix', im') -The following provide us higher order functions that, when applied -to a function, operate on pairs. +#ifdef __GLASGOW_HASKELL__ +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-} -\begin{code} -#if NOT_USED -applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d) -applyToPair (f,g) (x,y) = (f x, g y) +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-} -applyToFst :: (a -> c) -> (a,b)-> (c,b) -applyToFst f (x,y) = (f x,y) +{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} -applyToSnd :: (b -> d) -> (a,b) -> (a,d) -applyToSnd f (x,y) = (x,f y) +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} #endif + +-- | Search for possible matches to the users input in the given list, returning a small number of ranked results +fuzzyMatch :: String -> [String] -> [String] +fuzzyMatch user_entered possibilites = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + [ (poss, distance) | poss <- possibilites + , let distance = restrictedDamerauLevenshteinDistance poss user_entered + , distance <= fuzzy_threshold ] + where -- Work out an approriate match threshold (about a quarter of the # of characters the user entered) + fuzzy_threshold = max (round $ fromInteger (genericLength user_entered) / (4 :: Rational)) 1 + mAX_RESULTS = 3 \end{code} +%************************************************************************ +%* * +\subsection[Utils-pairs]{Pairs} +%* * +%************************************************************************ + \begin{code} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs @@ -760,59 +796,74 @@ global a = unsafePerformIO (newIORef a) \begin{code} consIORef :: IORef [a] -> a -> IO () consIORef var x = do - xs <- readIORef var - writeIORef var (x:xs) + atomicModifyIORef var (\xs -> (x:xs,())) +\end{code} + +\begin{code} +globalMVar :: a -> MVar a +globalMVar a = unsafePerformIO (newMVar a) + +globalEmptyMVar :: MVar a +globalEmptyMVar = unsafePerformIO newEmptyMVar \end{code} Module names: \begin{code} +looksLikeModuleName :: String -> Bool looksLikeModuleName [] = False looksLikeModuleName (c:cs) = isUpper c && go cs where go [] = True - go ('.':cs) = looksLikeModuleName cs - go (c:cs) = (isAlphaNum c || c == '_') && go cs + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_') && go cs \end{code} Akin to @Prelude.words@, but acts like the Bourne shell, treating -quoted strings and escaped characters within the input as solid blocks -of characters. Doesn't raise any exceptions on malformed escapes or -quoting. +quoted strings as Haskell Strings, and also parses Haskell [String] +syntax. \begin{code} -toArgs :: String -> [String] -toArgs "" = [] -toArgs s = - case dropWhile isSpace s of -- drop initial spacing - [] -> [] -- empty, so no more tokens - rem -> let (tok,aft) = token rem [] in tok : toArgs aft +getCmd :: String -> Either String -- Error + (String, String) -- (Cmd, Rest) +getCmd s = case break isSpace $ dropWhile isSpace s of + ([], _) -> Left ("Couldn't find command in " ++ show s) + res -> Right res + +toCmdArgs :: String -> Either String -- Error + (String, [String]) -- (Cmd, Args) +toCmdArgs s = case getCmd s of + Left err -> Left err + Right (cmd, s') -> case toArgs s' of + Left err -> Left err + Right args -> Right (cmd, args) + +toArgs :: String -> Either String -- Error + [String] -- Args +toArgs str + = case dropWhile isSpace str of + s@('[':_) -> case reads s of + [(args, spaces)] + | all isSpace spaces -> + Right args + _ -> + Left ("Couldn't read " ++ show str ++ "as [String]") + s -> toArgs' s where - -- Grab a token off the string, given that the first character exists and - -- isn't whitespace. The second argument is an accumulator which has to be - -- reversed at the end. - token [] acc = (reverse acc,[]) -- out of characters - token ('\\':c:aft) acc -- escapes - = token aft ((escape c) : acc) - token (q:aft) acc | q == '"' || q == '\'' -- open quotes - = let (aft',acc') = quote q aft acc in token aft' acc' - token (c:aft) acc | isSpace c -- unescaped, unquoted spacing - = (reverse acc,aft) - token (c:aft) acc -- anything else goes in the token - = token aft (c:acc) - - -- Get the appropriate character for a single-character escape. - escape 'n' = '\n' - escape 't' = '\t' - escape 'r' = '\r' - escape c = c - - -- Read into accumulator until a quote character is found. - quote qc = - let quote' [] acc = ([],acc) - quote' ('\\':c:aft) acc = quote' aft ((escape c) : acc) - quote' (c:aft) acc | c == qc = (aft,acc) - quote' (c:aft) acc = quote' aft (c:acc) - in quote' + toArgs' s = case dropWhile isSpace s of + [] -> Right [] + ('"' : _) -> case reads s of + [(arg, rest)] + -- rest must either be [] or start with a space + | all isSpace (take 1 rest) -> + case toArgs' rest of + Left err -> Left err + Right args -> Right (arg : args) + _ -> + Left ("Couldn't read " ++ show s ++ "as String") + s' -> case break isSpace s' of + (arg, s'') -> case toArgs' s'' of + Left err -> Left err + Right args -> Right (arg : args) \end{code} -- ----------------------------------------------------------------------------- @@ -820,24 +871,23 @@ toArgs s = \begin{code} readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" -readRational__ r = do +readRational__ r = do (n,d,s) <- readFix r (k,t) <- readExp s return ((n%1)*10^^(k-d), t) where readFix r = do - (ds,s) <- lexDecDigits r - (ds',t) <- lexDotDigits s - return (read (ds++ds'), length ds', t) + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = return (0,s) + readExp s = return (0,s) readExp' ('+':s) = readDec s - readExp' ('-':s) = do - (k,t) <- readDec s - return (-k,t) - readExp' s = readDec s + readExp' ('-':s) = do (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s readDec s = do (ds,r) <- nonnull isDigit s @@ -860,39 +910,28 @@ readRational top_s where read_me s = case (do { (x,"") <- readRational__ s ; return x }) of - [x] -> x - [] -> error ("readRational: no parse:" ++ top_s) - _ -> error ("readRational: ambiguous parse:" ++ top_s) + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) ----------------------------------------------------------------------------- -- Create a hierarchy of directories createDirectoryHierarchy :: FilePath -> IO () +createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack createDirectoryHierarchy dir = do b <- doesDirectoryExist dir - when (not b) $ do - createDirectoryHierarchy (directoryOf dir) - createDirectory dir + unless b $ do createDirectoryHierarchy (takeDirectory dir) + createDirectory dir ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists. --- +-- doesDirNameExist :: FilePath -> IO Bool -doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath) - --- ----------------------------------------------------------------------------- --- Exception utils - -later = flip finally - -handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a -handleDyn = flip catchDyn - -handle :: (Exception -> IO a) -> IO a -> IO a -handle h f = f `Exception.catch` \e -> case e of - ExitException _ -> throw e - _ -> h e +doesDirNameExist fpath = case takeDirectory fpath of + "" -> return True -- XXX Hack + _ -> doesDirectoryExist (takeDirectory fpath) -- -------------------------------------------------------------- -- check existence & modification time at the same time @@ -900,52 +939,9 @@ handle h f = f `Exception.catch` \e -> case e of modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) modificationTimeIfExists f = do (do t <- getModificationTime f; return (Just t)) - `IO.catch` \e -> if isDoesNotExistError e - then return Nothing - else ioError e - --- -------------------------------------------------------------- --- Filename manipulation - --- Filenames are kept "normalised" inside GHC, using '/' as the path --- separator. On Windows these functions will also recognise '\\' as --- the path separator, but will generally construct paths using '/'. - -type Suffix = String - -splitFilename :: String -> (String,Suffix) -splitFilename f = splitLongestPrefix f (=='.') - -basenameOf :: FilePath -> String -basenameOf = fst . splitFilename - -suffixOf :: FilePath -> Suffix -suffixOf = snd . splitFilename - -joinFileExt :: String -> String -> FilePath -joinFileExt path "" = path -joinFileExt path ext = path ++ '.':ext - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext") -splitFilenameDir :: String -> (String,String) -splitFilenameDir str - = let (dir, rest) = splitLongestPrefix str isPathSeparator - (dir', rest') | null rest = (".", dir) - | otherwise = (dir, rest) - in (dir', rest') - --- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext") -splitFilename3 :: String -> (String,String,Suffix) -splitFilename3 str - = let (dir, rest) = splitFilenameDir str - (name, ext) = splitFilename rest - in (dir, name, ext) - -joinFileName :: String -> String -> FilePath -joinFileName "" fname = fname -joinFileName "." fname = fname -joinFileName dir "" = dir -joinFileName dir fname = dir ++ '/':fname + `IO.catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string @@ -960,36 +956,13 @@ splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) splitLongestPrefix str pred | null r_pre = (str, []) | otherwise = (reverse (tail r_pre), reverse r_suf) - -- 'tail' drops the char satisfying 'pred' - where - (r_suf, r_pre) = break pred (reverse str) - -replaceFilenameSuffix :: FilePath -> Suffix -> FilePath -replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf - --- directoryOf strips the filename off the input string, returning --- the directory. -directoryOf :: FilePath -> String -directoryOf = fst . splitFilenameDir - --- filenameOf strips the directory off the input string, returning --- the filename. -filenameOf :: FilePath -> String -filenameOf = snd . splitFilenameDir - -replaceFilenameDirectory :: FilePath -> String -> FilePath -replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path + -- 'tail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred (reverse str) escapeSpaces :: String -> String escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" -isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif +type Suffix = String -------------------------------------------------------------- -- * Search path @@ -1003,60 +976,54 @@ parseSearchPath path = split path split :: String -> [String] split s = case rest' of - [] -> [chunk] + [] -> [chunk] _:rest -> chunk : split rest where - chunk = + chunk = case chunk' of #ifdef mingw32_HOST_OS ('\"':xs@(_:_)) | last xs == '\"' -> init xs #endif _ -> chunk' - (chunk', rest') = break (==searchPathSeparator) s + (chunk', rest') = break isSearchPathSeparator s --- | A platform-specific character used to separate search path strings in --- environment variables. The separator is a colon (\":\") on Unix and Macintosh, --- and a semicolon (\";\") on the Windows operating system. -searchPathSeparator :: Char -#if mingw32_HOST_OS || mingw32_TARGET_OS -searchPathSeparator = ';' -#else -searchPathSeparator = ':' -#endif +data Direction = Forwards | Backwards ------------------------------------------------------------------------------ --- Convert filepath into platform / MSDOS form. - --- We maintain path names in Unix form ('/'-separated) right until --- the last moment. On Windows we dos-ify them just before passing them --- to the Windows command. --- --- The alternative, of using '/' consistently on Unix and '\' on Windows, --- proved quite awkward. There were a lot more calls to platformPath, --- and even on Windows we might invoke a unix-like utility (eg 'sh'), which --- interpreted a command line 'foo\baz' as 'foobaz'. - -normalisePath :: String -> String --- Just changes '\' to '/' - -pgmPath :: String -- Directory string in Unix format - -> String -- Program name with no directory separators - -- (e.g. copy /y) - -> String -- Program invocation string in native format - -#if defined(mingw32_HOST_OS) ---------------------- Windows version ------------------ -normalisePath xs = subst '\\' '/' xs -pgmPath dir pgm = platformPath dir ++ '\\' : pgm -platformPath p = subst '/' '\\' p - -subst a b ls = map (\ x -> if x == a then b else x) ls -#else ---------------------- Non-Windows version -------------- -normalisePath xs = xs -pgmPath dir pgm = dir ++ '/' : pgm -platformPath stuff = stuff --------------------------------------------------------- +reslash :: Direction -> FilePath -> FilePath +reslash d = f + where f ('/' : xs) = slash : f xs + f ('\\' : xs) = slash : f xs + f (x : xs) = x : f xs + f "" = "" + slash = case d of + Forwards -> '/' + Backwards -> '\\' +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-Data]{Utils for defining Data instances} +%* * +%************************************************************************ + +These functions helps us to define Data instances for abstract types. + +\begin{code} +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix +\end{code} + +\begin{code} +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] +\end{code} + +\begin{code} +-- Old GHC versions come with a base library with this function misspelled. +#if __GLASGOW_HASKELL__ < 612 +mkNoRepType :: String -> DataType +mkNoRepType = mkNorepType #endif \end{code} +