X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=5cf020f7f56929ed598f33f44977e28e493182b4;hp=1ecf82c03848d507a452257fb6502c770b92d614;hb=4fa44a3ae9c36222ccb460ba3ed24e46bf7c70ae;hpb=43d9be898eadb04950bc0b0b272e0f05aedb463d diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 1ecf82c..5cf020f 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -2,20 +2,25 @@ % (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 ( - debugIsOn, ghciTablesNextToCode, + -- * Flags dependent on the compiler build + ghciSupported, debugIsOn, ghciTablesNextToCode, picIsOn, isWindowsHost, isWindowsTarget, isDarwinTarget, - -- general list processing + -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, + + unzipWith, + mapFst, mapSnd, mapAndUnzip, mapAndUnzip3, nOfThem, filterOut, partitionWith, splitEithers, - foldl1', + + foldl1', foldl2, count, all2, lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, equalLength, compareLength, @@ -25,49 +30,44 @@ module Util ( isIn, isn'tIn, - -- for-loop + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, + + -- * For loop nTimes, - -- sorting + -- * Sorting sortLe, sortWith, on, - -- transitive closures - transitiveClosure, - - -- accumulating - foldl2, count, all2, - - takeList, dropList, splitAtList, split, - - -- comparisons + -- * Comparisons isEqual, eqListBy, - thenCmp, cmpList, maybePrefixMatch, + thenCmp, cmpList, removeSpaces, - -- strictness - seqList, - - -- pairs - unzipWith, + -- * Transitive closures + transitiveClosure, - global, consIORef, + -- * Strictness + seqList, - -- module names + -- * Module names looksLikeModuleName, + -- * Argument processing getCmd, toCmdArgs, toArgs, - -- Floating point stuff + -- * Floating point readRational, - -- IO-ish utilities + -- * IO-ish utilities createDirectoryHierarchy, doesDirNameExist, modificationTimeIfExists, - later, handleDyn, handle, + global, consIORef, globalMVar, globalEmptyMVar, - -- Filename utils + -- * Filenames and paths Suffix, splitLongestPrefix, escapeSpaces, @@ -79,25 +79,22 @@ module Util ( import Panic -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 Data.List hiding (group) +import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar ) -import qualified Data.List as List ( elem ) #ifdef DEBUG -import qualified Data.List as List ( notElem ) +import qualified Data.List as List ( elem, notElem ) import FastTypes #endif import Control.Monad ( unless ) -import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError ) +import System.IO.Error as IO ( catch, isDoesNotExistError ) import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) -import System.FilePath hiding ( searchPathSeparator ) +import System.FilePath import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) import Data.Ratio ( (%) ) import System.Time ( ClockTime ) @@ -107,11 +104,27 @@ infixr 9 `thenCmp` %************************************************************************ %* * -\subsection{Is DEBUG on, are we on Windows?} +\subsection{Is DEBUG on, are we on Windows, etc?} %* * %************************************************************************ +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} +ghciSupported :: Bool +#ifdef GHCI +ghciSupported = True +#else +ghciSupported = False +#endif + debugIsOn :: Bool #ifdef DEBUG debugIsOn = True @@ -126,6 +139,13 @@ ghciTablesNextToCode = True ghciTablesNextToCode = False #endif +picIsOn :: Bool +#ifdef __PIC__ +picIsOn = True +#else +picIsOn = False +#endif + isWindowsHost :: Bool #ifdef mingw32_HOST_OS isWindowsHost = True @@ -155,7 +175,7 @@ isDarwinTarget = False %************************************************************************ \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 @@ -170,12 +190,13 @@ nTimes n f = f . nTimes (n-1) f \begin{code} filterOut :: (a->Bool) -> [a] -> [a] --- Like filter, only reverses the sense of the test +-- ^ 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 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +-- ^ 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) @@ -183,6 +204,7 @@ partitionWith f (x:xs) = case f x of 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) @@ -227,8 +249,7 @@ zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) \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 [] _ = [] -- We want to write this, but with GHC 6.4 we get a warning, so it @@ -242,8 +263,8 @@ zipLazy (x:xs) zs = let y : ys = zs \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 _ _ _ [] _ = [] stretchZipWith p z f (x:xs) ys @@ -284,14 +305,14 @@ 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] @@ -305,9 +326,10 @@ atLength atLenPred atEndPred ls 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 @@ -398,16 +420,6 @@ isn'tIn msg x ys # endif /* DEBUG */ \end{code} -foldl1' was added in GHC 6.4 - -\begin{code} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604 -foldl1' :: (a -> a -> a) -> [a] -> a -foldl1' f (x:xs) = foldl' f x xs -foldl1' _ [] = panic "foldl1'" -#endif -\end{code} - %************************************************************************ %* * \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} @@ -597,6 +609,10 @@ 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 snocView [] = Nothing @@ -649,15 +665,6 @@ cmpList cmp (a:as) (b:bs) \end{code} \begin{code} --- This (with a more general type) is Data.List.stripPrefix from GHC 6.8. --- This definition can be removed once we require at least 6.8 to build. -maybePrefixMatch :: String -> String -> Maybe String -maybePrefixMatch [] rest = Just rest -maybePrefixMatch (_:_) [] = Nothing -maybePrefixMatch (p:pat) (r:rest) - | p == r = maybePrefixMatch pat rest - | otherwise = Nothing - removeSpaces :: String -> String removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace \end{code} @@ -693,6 +700,14 @@ consIORef var x = do writeIORef var (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} @@ -819,20 +834,6 @@ doesDirNameExist fpath = case takeDirectory fpath of "" -> return True -- XXX Hack _ -> doesDirectoryExist (takeDirectory fpath) --- ----------------------------------------------------------------------------- --- Exception utils - -later :: IO b -> IO a -> IO a -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 - -- -------------------------------------------------------------- -- check existence & modification time at the same time @@ -886,17 +887,7 @@ parseSearchPath path = split path #endif _ -> chunk' - (chunk', rest') = break (==searchPathSeparator) 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 + (chunk', rest') = break isSearchPathSeparator s data Direction = Forwards | Backwards