X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=1d11b90a557945d1cc449efb4ba744e6df9634e8;hb=e4417dcd4679da9c6b18c02ff667199c572bed89;hp=b9679177534b9f9914707d4bf31e379696783a3f;hpb=c9b6b5e89b9f75bc40a9964fdd154242dd4ed45b;p=ghc-hetmet.git diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index b967917..1d11b90 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -6,6 +6,7 @@ \begin{code} module Util ( + debugIsOn, -- general list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, @@ -53,7 +54,7 @@ module Util ( -- module names looksLikeModuleName, - toArgs, + getCmd, toCmdArgs, toArgs, -- Floating point stuff readRational, @@ -73,8 +74,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 @@ -107,6 +106,21 @@ infixr 9 `thenCmp` %************************************************************************ %* * +\subsection{-DDEBUG} +%* * +%************************************************************************ + +\begin{code} +debugIsOn :: Bool +#ifdef DEBUG +debugIsOn = True +#else +debugIsOn = False +#endif +\end{code} + +%************************************************************************ +%* * \subsection{A for loop} %* * %************************************************************************ @@ -163,22 +177,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} @@ -331,21 +345,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} @@ -353,7 +367,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'" @@ -657,44 +671,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} -- -----------------------------------------------------------------------------