X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FUtil.lhs;h=522f795bcb458f0b275868a6a3532e27db6050c4;hp=e692ff1aa3afcd868b7deaafcf44f9e9ea5bc39e;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs
index e692ff1..522f795 100644
--- a/compiler/utils/Util.lhs
+++ b/compiler/utils/Util.lhs
@@ -12,7 +12,10 @@ module Util (
 	mapFst, mapSnd,
 	mapAndUnzip, mapAndUnzip3,
 	nOfThem, filterOut,
-	lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+
+	lengthExceeds, lengthIs, lengthAtLeast, 
+	listLengthCmp, atLength, equalLength, compareLength,
+
 	isSingleton, only, singleton,
 	notNull, snocView,
 
@@ -34,7 +37,7 @@ module Util (
 	takeList, dropList, splitAtList, split,
 
 	-- comparisons
-	isEqual, eqListBy, equalLength, compareLength,
+	isEqual, eqListBy, 
 	thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
 	removeSpaces,
 
@@ -300,6 +303,18 @@ listLengthCmp = atLength atLen atEnd
   atLen []     = EQ
   atLen _      = GT
 
+equalLength :: [a] -> [b] -> Bool
+equalLength [] []         = True
+equalLength (_:xs) (_:ys) = equalLength xs ys
+equalLength xs    ys      = False
+
+compareLength :: [a] -> [b] -> Ordering
+compareLength [] []         = EQ
+compareLength (_:xs) (_:ys) = compareLength xs ys
+compareLength [] _ys        = LT
+compareLength _xs []        = GT
+
+----------------------------
 singleton :: a -> [a]
 singleton x = [x]
 
@@ -311,15 +326,6 @@ notNull :: [a] -> Bool
 notNull [] = False
 notNull _  = True
 
-snocView :: [a] -> Maybe ([a],a)
-	-- Split off the last element
-snocView [] = Nothing
-snocView xs = go [] xs
-	    where
-		-- Invariant: second arg is non-empty
-	      go acc [x]    = Just (reverse acc, x)
-	      go acc (x:xs) = go (x:acc) xs
-
 only :: [a] -> a
 #ifdef DEBUG
 only [a] = a
@@ -614,6 +620,15 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'')
     where
       (ys', ys'') = splitAtList xs ys
 
+snocView :: [a] -> Maybe ([a],a)
+	-- Split off the last element
+snocView [] = Nothing
+snocView xs = go [] xs
+	    where
+		-- Invariant: second arg is non-empty
+	      go acc [x]    = Just (reverse acc, x)
+	      go acc (x:xs) = go (x:acc) xs
+
 split :: Char -> String -> [String]
 split c s = case rest of
 		[]     -> [chunk] 
@@ -645,17 +660,6 @@ eqListBy eq []     []     = True
 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 eqListBy eq xs     ys     = False
 
-equalLength :: [a] -> [b] -> Bool
-equalLength [] []         = True
-equalLength (_:xs) (_:ys) = equalLength xs ys
-equalLength xs    ys      = False
-
-compareLength :: [a] -> [b] -> Ordering
-compareLength [] []         = EQ
-compareLength (_:xs) (_:ys) = compareLength xs ys
-compareLength [] _ys        = LT
-compareLength _xs []        = GT
-
 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
     -- `cmpList' uses a user-specified comparer
 
@@ -753,29 +757,45 @@ looksLikeModuleName (c:cs) = isUpper c && go cs
 	go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 \end{code}
 
-Akin to @Prelude.words@, but sensitive to dquoted entities treating
-them as single words.
+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.
 
 \begin{code}
 toArgs :: String -> [String]
 toArgs "" = []
 toArgs s  =
-  case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
-    (w,aft) ->
-       (\ ws -> if null w then ws else w : ws) $
-       case aft of
-	 []           -> []
-	 (x:xs)
-	   | x /= '"'  -> toArgs xs
-	   | otherwise ->
-             case lex aft of
-	       ((str,rs):_) -> stripQuotes str : toArgs rs
-	       _            -> [aft]
+  case dropWhile isSpace s of  -- drop initial spacing
+    [] -> []  -- empty, so no more tokens
+    rem -> let (tok,aft) = token rem [] in tok : toArgs aft
  where
-    -- strip away dquotes; assume first and last chars contain quotes.
-   stripQuotes :: String -> String
-   stripQuotes ('"':xs)  = init xs
-   stripQuotes xs        = xs
+   -- 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'
 \end{code}
 
 -- -----------------------------------------------------------------------------