zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
mapAndUnzip, mapAndUnzip3,
- nOfThem,
+ nOfThem, filterOut,
lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
isSingleton, only,
notNull, snocView,
-- comparisons
eqListBy, equalLength, compareLength,
- thenCmp, cmpList, prefixMatch, suffixMatch,
+ thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
-- strictness
foldl', seqList,
-- module names
looksLikeModuleName,
+
+ toArgs,
+
+ -- Floating point stuff
+ readRational,
) where
-#include "../includes/config.h"
+#include "../includes/ghcconfig.h"
#include "HsVersions.h"
import Panic ( panic, trace )
import List ( zipWith4 )
#endif
-import Char ( isUpper, isAlphaNum )
+import Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
+import Ratio ( (%) )
infixr 9 `thenCmp`
\end{code}
%* *
%************************************************************************
+\begin{code}
+filterOut :: (a->Bool) -> [a] -> [a]
+-- Like filter, only reverses the sense of the test
+filterOut p [] = []
+filterOut p (x:xs) | p x = filterOut p xs
+ | otherwise = x : filterOut p xs
+\end{code}
+
A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
are of equal length. Alastair Reid thinks this should only happen if
DEBUGging on; hey, why not?
notElem__ x [] = True
notElem__ x (y:ys) = x /= y && notElem__ x ys
-# else {- DEBUG -}
+# else /* DEBUG */
isIn msg x ys
= elem (_ILIT 0) x ys
where
| 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 -}
+# endif /* DEBUG */
\end{code}
%************************************************************************
balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
balancedFold' f xs = xs
-generalMergeSort p [] = []
-generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
-
generalNaturalMergeSort p [] = []
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
#if NOT_USED
+generalMergeSort p [] = []
+generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
+
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
mergeSort = generalMergeSort (<=)
prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
| otherwise = False
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch [] rest = Just rest
+maybePrefixMatch (_:_) [] = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+ | p == r = maybePrefixMatch pat rest
+ | otherwise = Nothing
+
suffixMatch :: Eq a => [a] -> [a] -> Bool
suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
\end{code}
applyToSnd :: (b -> d) -> (a,b) -> (a,d)
applyToSnd f (x,y) = (x,f y)
#endif
-
-foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
-foldPair fg ab [] = ab
-foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
- where (u,v) = foldPair fg ab abs
\end{code}
\begin{code}
go ('.':cs) = looksLikeModuleName 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.
+
+\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]
+ where
+ -- strip away dquotes; assume first and last chars contain quotes.
+ stripQuotes :: String -> String
+ stripQuotes ('"':xs) = init xs
+ stripQuotes xs = xs
+\end{code}
+
+-- -----------------------------------------------------------------------------
+-- Floats
+
+\begin{code}
+readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
+readRational__ r = do
+ (n,d,s) <- readFix r
+ (k,t) <- readExp s
+ return ((n%1)*10^^(k-d), t)
+ where
+ readFix r = do
+ (ds,s) <- lexDecDigits r
+ (ds',t) <- lexDotDigits s
+ return (read (ds++ds'), length ds', t)
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = return (0,s)
+
+ readExp' ('+':s) = readDec s
+ readExp' ('-':s) = do
+ (k,t) <- readDec s
+ return (-k,t)
+ readExp' s = readDec s
+
+ readDec s = do
+ (ds,r) <- nonnull isDigit s
+ return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
+ r)
+
+ lexDecDigits = nonnull isDigit
+
+ lexDotDigits ('.':s) = return (span isDigit s)
+ lexDotDigits s = return ("",s)
+
+ nonnull p s = do (cs@(_:_),t) <- return (span p s)
+ return (cs,t)
+
+readRational :: String -> Rational -- NB: *does* handle a leading "-"
+readRational top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case (do { (x,"") <- readRational__ s ; return x }) of
+ [x] -> x
+ [] -> error ("readRational: no parse:" ++ top_s)
+ _ -> error ("readRational: ambiguous parse:" ++ top_s)
+\end{code}
projects / ghc-hetmet.git / blobdiff