\section[Util]{Highly random utility functions}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module Util (
-- general list processing
mapFst, mapSnd,
mapAndUnzip, mapAndUnzip3,
nOfThem, filterOut, partitionWith, splitEithers,
+ foldl1',
lengthExceeds, lengthIs, lengthAtLeast,
listLengthCmp, atLength, equalLength, compareLength,
nTimes,
-- sorting
- sortLe, sortWith,
+ sortLe, sortWith, on,
-- transitive closures
transitiveClosure,
removeSpaces,
-- strictness
- foldl', seqList,
+ seqList,
-- pairs
unzipWith,
later, handleDyn, handle,
-- Filename utils
- Suffix,
- splitFilename, suffixOf, basenameOf, joinFileExt,
- splitFilenameDir, joinFileName,
- splitFilename3,
+ Suffix,
splitLongestPrefix,
- replaceFilenameSuffix, directoryOf, filenameOf,
- replaceFilenameDirectory,
- escapeSpaces, isPathSeparator,
+ escapeSpaces,
parseSearchPath,
- normalisePath, platformPath, pgmPath,
) where
#include "HsVersions.h"
-import Panic ( panic, trace )
import FastTypes
+#if defined(DEBUG) || __GLASGOW_HASKELL__ < 604
+import Panic
+#endif
+
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 qualified Data.List as List ( elem, notElem )
-
-#ifndef DEBUG
-import Data.List ( zipWith4 )
+import qualified Data.List as List ( elem )
+#ifdef DEBUG
+import qualified Data.List as List ( notElem )
#endif
-import Control.Monad ( when )
+import Control.Monad ( unless )
import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
import System.Directory ( doesDirectoryExist, createDirectory,
getModificationTime )
+import System.FilePath hiding ( searchPathSeparator )
import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Data.Ratio ( (%) )
import System.Time ( ClockTime )
# endif /* DEBUG */
\end{code}
+foldl1' was added in GHC 6.4
+
+\begin{code}
+#if __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}
sortWith get_key xs = sortLe le xs
where
x `le` y = get_key x < get_key y
+
+on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
+on cmp sel = \x y -> sel x `cmp` sel y
+
\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}
\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
-- 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)
+ 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)
+doesDirNameExist fpath = case takeDirectory fpath of
+ "" -> return True -- XXX Hack
+ dir -> doesDirectoryExist (takeDirectory fpath)
-- -----------------------------------------------------------------------------
-- Exception utils
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
-
-- split a string at the last character where 'pred' is True,
-- returning a pair of strings. The first component holds the string
-- up (but not including) the last character for which 'pred' returned
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
-
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
#else
searchPathSeparator = ':'
#endif
-
------------------------------------------------------------------------------
--- 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
---------------------------------------------------------
-#endif
\end{code}
projects / ghc-hetmet.git / blobdiff