X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FList.hs;h=bb71da5f06b9b9a4b735841f6ff2d165a39cc5bc;hb=HEAD;hp=fce4492b8e725429262d86603440491f63b3aaa6;hpb=77ffcd84fa031cfc8c3acbc73ba5c6a30dad9e4c;p=ghc-base.git diff --git a/Data/List.hs b/Data/List.hs index fce4492..bb71da5 100644 --- a/Data/List.hs +++ b/Data/List.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -fno-implicit-prelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.List @@ -37,6 +38,9 @@ module Data.List , intersperse -- :: a -> [a] -> [a] , intercalate -- :: [a] -> [[a]] -> [a] , transpose -- :: [[a]] -> [[a]] + + , subsequences -- :: [a] -> [[a]] + , permutations -- :: [a] -> [[a]] -- * Reducing lists (folds) @@ -227,10 +231,10 @@ infix 5 \\ -- comment to fool cpp -- It returns 'Nothing' if the list did not start with the prefix -- given, or 'Just' the list after the prefix, if it does. -- --- > stripPrefix "foo" "foobar" -> Just "bar" --- > stripPrefix "foo" "foo" -> Just "" --- > stripPrefix "foo" "barfoo" -> Nothing --- > stripPrefix "foo" "barfoobaz" -> Nothing +-- > stripPrefix "foo" "foobar" == Just "bar" +-- > stripPrefix "foo" "foo" == Just "" +-- > stripPrefix "foo" "barfoo" == Nothing +-- > stripPrefix "foo" "barfoobaz" == Nothing stripPrefix :: Eq a => [a] -> [a] -> Maybe [a] stripPrefix [] ys = Just ys stripPrefix (x:xs) (y:ys) @@ -294,12 +298,12 @@ isSuffixOf x y = reverse x `isPrefixOf` reverse y -- -- Example: -- --- >isInfixOf "Haskell" "I really like Haskell." -> True --- >isInfixOf "Ial" "I really like Haskell." -> False +-- >isInfixOf "Haskell" "I really like Haskell." == True +-- >isInfixOf "Ial" "I really like Haskell." == False isInfixOf :: (Eq a) => [a] -> [a] -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) --- | The 'nub' function removes duplicate elements from a list. +-- | /O(n^2)/. The 'nub' function removes duplicate elements from a list. -- In particular, it keeps only the first occurrence of each element. -- (The name 'nub' means \`essence\'.) -- It is a special case of 'nubBy', which allows the programmer to supply @@ -339,7 +343,7 @@ nubBy eq l = nubBy' l [] -- 'y' is the potential new element elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool elem_by _ _ [] = False -elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs +elem_by eq y (x:xs) = y `eq` x || elem_by eq y xs #endif @@ -396,6 +400,9 @@ unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs -- > [1,2,3,4] `intersect` [2,4,6,8] == [2,4] -- -- If the first list contains duplicates, so will the result. +-- +-- > [1,2,2,3,4] `intersect` [6,4,4,2] == [2,2,4] +-- -- It is a special case of 'intersectBy', which allows the programmer to -- supply their own equality test. @@ -404,6 +411,8 @@ intersect = intersectBy (==) -- | The 'intersectBy' function is the non-overloaded version of 'intersect'. intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy _ [] _ = [] +intersectBy _ _ [] = [] intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -- | The 'intersperse' function takes an element and a list and @@ -414,8 +423,16 @@ intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] intersperse :: a -> [a] -> [a] intersperse _ [] = [] -intersperse _ [x] = [x] -intersperse sep (x:xs) = x : sep : intersperse sep xs +intersperse sep (x:xs) = x : prependToAll sep xs + + +-- Not exported: +-- We want to make every element in the 'intersperse'd list available +-- as soon as possible to avoid space leaks. Experiments suggested that +-- a separate top-level helper is more efficient than a local worker. +prependToAll :: a -> [a] -> [a] +prependToAll _ [] = [] +prependToAll sep (x:xs) = sep : x : prependToAll sep xs -- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the @@ -431,7 +448,7 @@ intercalate xs xss = concat (intersperse xs xss) transpose :: [[a]] -> [[a]] transpose [] = [] transpose ([] : xss) = transpose xss -transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss]) +transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss]) -- | The 'partition' function takes a predicate a list and returns @@ -444,6 +461,7 @@ partition :: (a -> Bool) -> [a] -> ([a],[a]) {-# INLINE partition #-} partition p xs = foldr (select p) ([],[]) xs +select :: (a -> Bool) -> a -> ([a], [a]) -> ([a], [a]) select p x ~(ts,fs) | p x = (x:ts,fs) | otherwise = (ts, x:fs) @@ -540,22 +558,22 @@ strictMinimum xs = foldl1' min xs -- The list must be finite and non-empty. maximumBy :: (a -> a -> Ordering) -> [a] -> a maximumBy _ [] = error "List.maximumBy: empty list" -maximumBy cmp xs = foldl1 max xs +maximumBy cmp xs = foldl1 maxBy xs where - max x y = case cmp x y of - GT -> x - _ -> y + maxBy x y = case cmp x y of + GT -> x + _ -> y -- | The 'minimumBy' function takes a comparison function and a list -- and returns the least element of the list by the comparison function. -- The list must be finite and non-empty. minimumBy :: (a -> a -> Ordering) -> [a] -> a minimumBy _ [] = error "List.minimumBy: empty list" -minimumBy cmp xs = foldl1 min xs +minimumBy cmp xs = foldl1 minBy xs where - min x y = case cmp x y of - GT -> y - _ -> x + minBy x y = case cmp x y of + GT -> y + _ -> x -- | The 'genericLength' function is an overloaded version of 'length'. In -- particular, instead of returning an 'Int', it returns any type which is @@ -564,30 +582,39 @@ genericLength :: (Num i) => [b] -> i genericLength [] = 0 genericLength (_:l) = 1 + genericLength l +{-# RULES + "genericLengthInt" genericLength = (strictGenericLength :: [a] -> Int); + "genericLengthInteger" genericLength = (strictGenericLength :: [a] -> Integer); + #-} + +strictGenericLength :: (Num i) => [b] -> i +strictGenericLength l = gl l 0 + where + gl [] a = a + gl (_:xs) a = let a' = a + 1 in a' `seq` gl xs a' + -- | The 'genericTake' function is an overloaded version of 'take', which -- accepts any 'Integral' value as the number of elements to take. genericTake :: (Integral i) => i -> [a] -> [a] -genericTake 0 _ = [] +genericTake n _ | n <= 0 = [] genericTake _ [] = [] -genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs -genericTake _ _ = error "List.genericTake: negative argument" +genericTake n (x:xs) = x : genericTake (n-1) xs -- | The 'genericDrop' function is an overloaded version of 'drop', which -- accepts any 'Integral' value as the number of elements to drop. genericDrop :: (Integral i) => i -> [a] -> [a] -genericDrop 0 xs = xs +genericDrop n xs | n <= 0 = xs genericDrop _ [] = [] -genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs -genericDrop _ _ = error "List.genericDrop: negative argument" +genericDrop n (_:xs) = genericDrop (n-1) xs + -- | The 'genericSplitAt' function is an overloaded version of 'splitAt', which -- accepts any 'Integral' value as the position at which to split. genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b]) -genericSplitAt 0 xs = ([],xs) +genericSplitAt n xs | n <= 0 = ([],xs) genericSplitAt _ [] = ([],[]) -genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where - (xs',xs'') = genericSplitAt (n-1) xs -genericSplitAt _ _ = error "List.genericSplitAt: negative argument" +genericSplitAt n (x:xs) = (x:xs',xs'') where + (xs',xs'') = genericSplitAt (n-1) xs -- | The 'genericIndex' function is an overloaded version of '!!', which -- accepts any 'Integral' value as the index. @@ -717,18 +744,53 @@ groupBy eq (x:xs) = (x:ys) : groupBy eq zs -- -- > inits "abc" == ["","a","ab","abc"] -- +-- Note that 'inits' has the following strictness property: +-- @inits _|_ = [] : _|_@ inits :: [a] -> [[a]] -inits [] = [[]] -inits (x:xs) = [[]] ++ map (x:) (inits xs) +inits xs = [] : case xs of + [] -> [] + x : xs' -> map (x :) (inits xs') -- | The 'tails' function returns all final segments of the argument, -- longest first. For example, -- -- > tails "abc" == ["abc", "bc", "c",""] -- +-- Note that 'tails' has the following strictness property: +-- @tails _|_ = _|_ : _|_@ tails :: [a] -> [[a]] -tails [] = [[]] -tails xxs@(_:xs) = xxs : tails xs +tails xs = xs : case xs of + [] -> [] + _ : xs' -> tails xs' + +-- | The 'subsequences' function returns the list of all subsequences of the argument. +-- +-- > subsequences "abc" == ["","a","b","ab","c","ac","bc","abc"] +subsequences :: [a] -> [[a]] +subsequences xs = [] : nonEmptySubsequences xs + +-- | The 'nonEmptySubsequences' function returns the list of all subsequences of the argument, +-- except for the empty list. +-- +-- > nonEmptySubsequences "abc" == ["a","b","ab","c","ac","bc","abc"] +nonEmptySubsequences :: [a] -> [[a]] +nonEmptySubsequences [] = [] +nonEmptySubsequences (x:xs) = [x] : foldr f [] (nonEmptySubsequences xs) + where f ys r = ys : (x : ys) : r + + +-- | The 'permutations' function returns the list of all permutations of the argument. +-- +-- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"] +permutations :: [a] -> [[a]] +permutations xs0 = xs0 : perms xs0 [] + where + perms [] _ = [] + perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is) + where interleave xs r = let (_,zs) = interleave' id xs r in zs + interleave' _ [] r = (ts, r) + interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r + in (y:us, f (t:y:us) : zs) ------------------------------------------------------------------------------ @@ -747,10 +809,50 @@ sort = sortBy compare sortBy cmp = foldr (insertBy cmp) [] #else +{- +GHC's mergesort replaced by a better implementation, 24/12/2009. +This code originally contributed to the nhc12 compiler by Thomas Nordin +in 2002. Rumoured to have been based on code by Lennart Augustsson, e.g. + http://www.mail-archive.com/haskell@haskell.org/msg01822.html +and possibly to bear similarities to a 1982 paper by Richard O'Keefe: +"A smooth applicative merge sort". + +Benchmarks show it to be often 2x the speed of the previous implementation. +Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/2143 +-} + +sort = sortBy compare +sortBy cmp = mergeAll . sequences + where + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs + ascending a as bs = as [a]: sequences bs + + mergeAll [x] = x + mergeAll xs = mergeAll (mergePairs xs) + + mergePairs (a:b:xs) = merge a b: mergePairs xs + mergePairs xs = xs + + merge as@(a:as') bs@(b:bs') + | a `cmp` b == GT = b:merge as bs' + | otherwise = a:merge as' bs + merge [] bs = bs + merge as [] = as + +{- sortBy cmp l = mergesort cmp l sort l = mergesort compare l -{- Quicksort replaced by mergesort, 14/5/2002. From: Ian Lynagh @@ -791,24 +893,23 @@ func 100000 sorted sort 5831.47 func 100000 sorted mergesort 2.23 func 100000 revsorted sort 5872.34 func 100000 revsorted mergesort 2.24 --} mergesort :: (a -> a -> Ordering) -> [a] -> [a] mergesort cmp = mergesort' cmp . map wrap mergesort' :: (a -> a -> Ordering) -> [[a]] -> [a] -mergesort' cmp [] = [] -mergesort' cmp [xs] = xs +mergesort' _ [] = [] +mergesort' _ [xs] = xs mergesort' cmp xss = mergesort' cmp (merge_pairs cmp xss) merge_pairs :: (a -> a -> Ordering) -> [[a]] -> [[a]] -merge_pairs cmp [] = [] -merge_pairs cmp [xs] = [xs] +merge_pairs _ [] = [] +merge_pairs _ [xs] = [xs] merge_pairs cmp (xs:ys:xss) = merge cmp xs ys : merge_pairs cmp xss merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -merge cmp [] ys = ys -merge cmp xs [] = xs +merge _ [] ys = ys +merge _ xs [] = xs merge cmp (x:xs) (y:ys) = case x `cmp` y of GT -> y : merge cmp (x:xs) ys @@ -817,8 +918,9 @@ merge cmp (x:xs) (y:ys) wrap :: a -> [a] wrap x = [x] -{- -OLD: qsort version + + +OLDER: qsort version -- qsort is stable and does not concatenate. qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] @@ -888,7 +990,7 @@ unfoldr f b = -- | A strict version of 'foldl'. foldl' :: (a -> b -> a) -> a -> [b] -> a #ifdef __GLASGOW_HASKELL__ -foldl' f z xs = lgo z xs +foldl' f z0 xs0 = lgo z0 xs0 where lgo z [] = z lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs #else @@ -942,10 +1044,23 @@ product l = prod l 1 -- characters. The resulting strings do not contain newlines. lines :: String -> [String] lines "" = [] +#ifdef __GLASGOW_HASKELL__ +-- Somehow GHC doesn't detect the selector thunks in the below code, +-- so s' keeps a reference to the first line via the pair and we have +-- a space leak (cf. #4334). +-- So we need to make GHC see the selector thunks with a trick. +lines s = cons (case break (== '\n') s of + (l, s') -> (l, case s' of + [] -> [] + _:s'' -> lines s'')) + where + cons ~(h, t) = h : t +#else lines s = let (l, s') = break (== '\n') s in l : case s' of [] -> [] (_:s'') -> lines s'' +#endif -- | 'unlines' is an inverse operation to 'lines'. -- It joins lines, after appending a terminating newline to each.