X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=7057d321a13956a3f94868301a2e67cb92c9539d;hb=85255a966b21172ce5a26c8a9cb0cdaf7315be95;hp=852bb90289e8dafb1dfeaec6ddd2c35044cda938;hpb=1994febdf9ae3d63029a837a6a10bda2690ddb48;p=ghc-hetmet.git diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 852bb90..7057d32 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, @@ -73,8 +75,6 @@ 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 @@ -94,7 +94,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 +107,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 +245,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} @@ -331,35 +393,25 @@ notElem__ x (y:ys) = x /= y && notElem__ x ys # else /* DEBUG */ isIn msg x ys - = elem (_ILIT 0) x ys + = elem (_ILIT(0)) x ys where elem _ _ [] = 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 + | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg) + (x `List.elem` (y:ys)) + | otherwise = x == y || elem (i +# _ILIT(1)) x ys isn'tIn msg x ys - = notElem (_ILIT 0) x ys + = notElem (_ILIT(0)) x ys where notElem _ _ [] = True notElem i x (y:ys) - | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) - (x `List.notElem` (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 # 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} @@ -657,44 +709,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} -- -----------------------------------------------------------------------------