X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=5d847213cc5287057865a9ab60ee0f8c7a08d135;hb=0b57caeac7840ef903a54ddd3196f3d573ca8cc4;hp=01685f3326806e16c36140dfe7fc2641eb64166b;hpb=206b4dec78250efef3cd927d64dc6cbc54a16c3d;p=ghc-hetmet.git diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 01685f3..5d84721 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -6,6 +6,8 @@ \begin{code} module Util ( + ghciSupported, debugIsOn, ghciTablesNextToCode, picIsOn, + isWindowsHost, isWindowsTarget, isDarwinTarget, -- general list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, @@ -53,7 +55,7 @@ module Util ( -- module names looksLikeModuleName, - toArgs, + getCmd, toCmdArgs, toArgs, -- Floating point stuff readRational, @@ -63,8 +65,6 @@ module Util ( doesDirNameExist, modificationTimeIfExists, - later, handleDyn, handle, - -- Filename utils Suffix, splitLongestPrefix, @@ -73,15 +73,10 @@ module Util ( Direction(..), reslash, ) where --- XXX This define is a bit of a hack, and should be done more nicely -#define FAST_STRING_NOT_NEEDED 1 #include "HsVersions.h" 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 ) @@ -94,7 +89,7 @@ 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 ) @@ -107,6 +102,63 @@ infixr 9 `thenCmp` %************************************************************************ %* * +\subsection{Is DEBUG on, are we on Windows, etc?} +%* * +%************************************************************************ + +\begin{code} +ghciSupported :: Bool +#ifdef GHCI +ghciSupported = True +#else +ghciSupported = False +#endif + +debugIsOn :: Bool +#ifdef DEBUG +debugIsOn = True +#else +debugIsOn = False +#endif + +ghciTablesNextToCode :: Bool +#ifdef GHCI_TABLES_NEXT_TO_CODE +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif + +picIsOn :: Bool +#ifdef __PIC__ +picIsOn = True +#else +picIsOn = False +#endif + +isWindowsHost :: Bool +#ifdef mingw32_HOST_OS +isWindowsHost = True +#else +isWindowsHost = False +#endif + +isWindowsTarget :: Bool +#ifdef mingw32_TARGET_OS +isWindowsTarget = True +#else +isWindowsTarget = False +#endif + +isDarwinTarget :: Bool +#ifdef darwin_TARGET_OS +isDarwinTarget = True +#else +isDarwinTarget = False +#endif +\end{code} + +%************************************************************************ +%* * \subsection{A for loop} %* * %************************************************************************ @@ -188,7 +240,12 @@ zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) zipLazy :: [a] -> [b] -> [(a,b)] zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys +-- 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} @@ -350,16 +407,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} @@ -657,44 +704,51 @@ looksLikeModuleName (c:cs) = isUpper 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} -- ----------------------------------------------------------------------------- @@ -764,20 +818,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