X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=82e039305afc2602027029c43b141fe0b10c56cc;hb=0323459f422cc1cc62335f2ef5aac68d6896473b;hp=90e7042baeae775d3f7bcee042ef1f5128fccf3c;hpb=a92fd1cad41b24fc0555aa95900b74fe7d07a9a3;p=ghc-hetmet.git diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 90e7042..82e0393 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -6,6 +6,8 @@ \begin{code} module Util ( + 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, @@ -70,10 +72,9 @@ module Util ( splitLongestPrefix, escapeSpaces, parseSearchPath, + 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 @@ -106,6 +107,56 @@ infixr 9 `thenCmp` %************************************************************************ %* * +\subsection{Is DEBUG on, are we on Windows?} +%* * +%************************************************************************ + +\begin{code} +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} %* * %************************************************************************ @@ -162,22 +213,22 @@ 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 _ _ [] [] = [] 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 _ _ [] [] [] = [] 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 _ _ [] [] [] [] = [] zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) #endif \end{code} @@ -187,7 +238,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} @@ -330,21 +386,21 @@ 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 i _ [] = False + 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 i x [] = True + 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} @@ -352,7 +408,7 @@ isn'tIn msg x ys foldl1' was added in GHC 6.4 \begin{code} -#if __GLASGOW_HASKELL__ < 604 +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604 foldl1' :: (a -> a -> a) -> [a] -> a foldl1' f (x:xs) = foldl' f x xs foldl1' _ [] = panic "foldl1'" @@ -656,44 +712,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} -- ----------------------------------------------------------------------------- @@ -841,4 +904,17 @@ searchPathSeparator = ';' #else searchPathSeparator = ':' #endif + +data Direction = Forwards | Backwards + +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} +