X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FList.hs;h=bb71da5f06b9b9a4b735841f6ff2d165a39cc5bc;hb=HEAD;hp=19dbc7d8619ffe0cc4f8d97b36c93b0b92e3d799;hpb=d7d871d674ee73c100ce5ab89ada80be2563ef79;p=ghc-base.git diff --git a/Data/List.hs b/Data/List.hs index 19dbc7d..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 @@ -14,7 +15,7 @@ ----------------------------------------------------------------------------- module Data.List - ( + ( #ifdef __NHC__ [] (..) , @@ -22,13 +23,13 @@ module Data.List -- * Basic functions - (++) -- :: [a] -> [a] -> [a] - , head -- :: [a] -> a - , last -- :: [a] -> a - , tail -- :: [a] -> [a] + (++) -- :: [a] -> [a] -> [a] + , head -- :: [a] -> a + , last -- :: [a] -> a + , tail -- :: [a] -> [a] , init -- :: [a] -> [a] - , null -- :: [a] -> Bool - , length -- :: [a] -> Int + , null -- :: [a] -> Bool + , length -- :: [a] -> Int -- * List transformations , map -- :: (a -> b) -> [a] -> [b] @@ -37,13 +38,16 @@ module Data.List , intersperse -- :: a -> [a] -> [a] , intercalate -- :: [a] -> [[a]] -> [a] , transpose -- :: [[a]] -> [[a]] + + , subsequences -- :: [a] -> [[a]] + , permutations -- :: [a] -> [[a]] -- * Reducing lists (folds) - , foldl -- :: (a -> b -> a) -> a -> [b] -> a - , foldl' -- :: (a -> b -> a) -> a -> [b] -> a - , foldl1 -- :: (a -> a -> a) -> [a] -> a - , foldl1' -- :: (a -> a -> a) -> [a] -> a + , foldl -- :: (a -> b -> a) -> a -> [b] -> a + , foldl' -- :: (a -> b -> a) -> a -> [b] -> a + , foldl1 -- :: (a -> a -> a) -> [a] -> a + , foldl1' -- :: (a -> a -> a) -> [a] -> a , foldr -- :: (a -> b -> b) -> b -> [a] -> b , foldr1 -- :: (a -> a -> a) -> [a] -> a @@ -51,7 +55,7 @@ module Data.List , concat -- :: [[a]] -> [a] , concatMap -- :: (a -> [b]) -> [a] -> [b] - , and -- :: [Bool] -> Bool + , and -- :: [Bool] -> Bool , or -- :: [Bool] -> Bool , any -- :: (a -> Bool) -> [a] -> Bool , all -- :: (a -> Bool) -> [a] -> Bool @@ -79,7 +83,7 @@ module Data.List , cycle -- :: [a] -> [a] -- ** Unfolding - , unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a] + , unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a] -- * Sublists @@ -113,26 +117,26 @@ module Data.List , lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b -- ** Searching with a predicate - , find -- :: (a -> Bool) -> [a] -> Maybe a - , filter -- :: (a -> Bool) -> [a] -> [a] + , find -- :: (a -> Bool) -> [a] -> Maybe a + , filter -- :: (a -> Bool) -> [a] -> [a] , partition -- :: (a -> Bool) -> [a] -> ([a], [a]) -- * Indexing lists -- | These functions treat a list @xs@ as a indexed collection, -- with indices ranging from 0 to @'length' xs - 1@. - , (!!) -- :: [a] -> Int -> a + , (!!) -- :: [a] -> Int -> a - , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int + , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int , elemIndices -- :: (Eq a) => a -> [a] -> [Int] - , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int + , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int , findIndices -- :: (a -> Bool) -> [a] -> [Int] -- * Zipping and unzipping lists , zip -- :: [a] -> [b] -> [(a,b)] - , zip3 + , zip3 , zip4, zip5, zip6, zip7 , zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c] @@ -146,18 +150,18 @@ module Data.List -- * Special lists -- ** Functions on strings - , lines -- :: String -> [String] - , words -- :: String -> [String] + , lines -- :: String -> [String] + , words -- :: String -> [String] , unlines -- :: [String] -> String , unwords -- :: [String] -> String -- ** \"Set\" operations - + , nub -- :: (Eq a) => [a] -> [a] , delete -- :: (Eq a) => a -> [a] -> [a] , (\\) -- :: (Eq a) => [a] -> [a] -> [a] - + , union -- :: (Eq a) => [a] -> [a] -> [a] , intersect -- :: (Eq a) => [a] -> [a] -> [a] @@ -188,7 +192,7 @@ module Data.List -- | The function is assumed to define a total ordering. , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a] , insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a] - , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a + , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a , minimumBy -- :: (a -> a -> Ordering) -> [a] -> a -- ** The \"@generic@\" operations @@ -209,7 +213,7 @@ import Prelude #endif import Data.Maybe -import Data.Char ( isSpace ) +import Data.Char ( isSpace ) #ifdef __GLASGOW_HASKELL__ import GHC.Num @@ -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) @@ -240,7 +244,7 @@ stripPrefix _ _ = Nothing -- | The 'elemIndex' function returns the index of the first element -- in the given list which is equal (by '==') to the query element, -- or 'Nothing' if there is no such element. -elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex :: Eq a => a -> [a] -> Maybe Int elemIndex x = findIndex (x==) -- | The 'elemIndices' function extends 'elemIndex', by returning the @@ -251,7 +255,7 @@ elemIndices x = findIndices (x==) -- | The 'find' function takes a predicate and a list and returns the -- first element in the list matching the predicate, or 'Nothing' if -- there is no such element. -find :: (a -> Bool) -> [a] -> Maybe a +find :: (a -> Bool) -> [a] -> Maybe a find p = listToMaybe . filter p -- | The 'findIndex' function takes a predicate and a list and returns @@ -269,10 +273,10 @@ findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] #else -- Efficient definition findIndices p ls = loop 0# ls - where - loop _ [] = [] - loop n (x:xs) | p x = I# n : loop (n +# 1#) xs - | otherwise = loop (n +# 1#) xs + where + loop _ [] = [] + loop n (x:xs) | p x = I# n : loop (n +# 1#) xs + | otherwise = loop (n +# 1#) xs #endif /* USE_REPORT_PRELUDE */ -- | The 'isPrefixOf' function takes two lists and returns 'True' @@ -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 @@ -309,28 +313,28 @@ nub :: (Eq a) => [a] -> [a] nub = nubBy (==) #else -- stolen from HBC -nub l = nub' l [] -- ' +nub l = nub' l [] -- ' where - nub' [] _ = [] -- ' - nub' (x:xs) ls -- ' - | x `elem` ls = nub' xs ls -- ' - | otherwise = x : nub' xs (x:ls) -- ' + nub' [] _ = [] -- ' + nub' (x:xs) ls -- ' + | x `elem` ls = nub' xs ls -- ' + | otherwise = x : nub' xs (x:ls) -- ' #endif -- | The 'nubBy' function behaves just like 'nub', except it uses a -- user-supplied equality predicate instead of the overloaded '==' -- function. -nubBy :: (a -> a -> Bool) -> [a] -> [a] +nubBy :: (a -> a -> Bool) -> [a] -> [a] #ifdef USE_REPORT_PRELUDE nubBy eq [] = [] nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) #else nubBy eq l = nubBy' l [] where - nubBy' [] _ = [] + nubBy' [] _ = [] nubBy' (y:ys) xs - | elem_by eq y xs = nubBy' ys xs - | otherwise = y : nubBy' ys (y:xs) + | elem_by eq y xs = nubBy' ys xs + | otherwise = y : nubBy' ys (y:xs) -- Not exported: -- Note that we keep the call to `eq` with arguments in the @@ -338,8 +342,8 @@ nubBy eq l = nubBy' l [] -- 'xs' is the list of things we've seen so far, -- '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 _ _ [] = False +elem_by eq y (x:xs) = y `eq` x || elem_by eq y xs #endif @@ -369,8 +373,8 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- It is a special case of 'deleteFirstsBy', which allows the programmer -- to supply their own equality test. -(\\) :: (Eq a) => [a] -> [a] -> [a] -(\\) = foldl (flip delete) +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl (flip delete) -- | The 'union' function returns the list union of the two lists. -- For example, @@ -383,8 +387,8 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- It is a special case of 'unionBy', which allows the programmer to supply -- their own equality test. -union :: (Eq a) => [a] -> [a] -> [a] -union = unionBy (==) +union :: (Eq a) => [a] -> [a] -> [a] +union = unionBy (==) -- | The 'unionBy' function is the non-overloaded version of 'union'. unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] @@ -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 @@ -412,10 +421,18 @@ intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -- -- > intersperse ',' "abcde" == "a,b,c,d,e" -intersperse :: a -> [a] -> [a] +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 @@ -428,10 +445,10 @@ intercalate xs xss = concat (intersperse xs xss) -- -- > transpose [[1,2,3],[4,5,6]] == [[1,4],[2,5],[3,6]] -transpose :: [[a]] -> [[a]] -transpose [] = [] -transpose ([] : xss) = transpose xss -transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss]) +transpose :: [[a]] -> [[a]] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [ t | (_:t) <- xss]) -- | The 'partition' function takes a predicate a list and returns @@ -440,10 +457,11 @@ transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t -- -- > partition p xs == (filter p xs, filter (not . p) xs) -partition :: (a -> Bool) -> [a] -> ([a],[a]) +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) @@ -452,30 +470,30 @@ select p x ~(ts,fs) | p x = (x:ts,fs) -- an accumulating parameter from left to right, and returning a final -- value of this accumulator together with the new list. mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list -mapAccumL _ s [] = (s, []) -mapAccumL f s (x:xs) = (s'',y:ys) - where (s', y ) = f s x - (s'',ys) = mapAccumL f s' xs + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumL _ s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs -- | The 'mapAccumR' function behaves like a combination of 'map' and -- 'foldr'; it applies a function to each element of a list, passing -- an accumulating parameter from right to left, and returning a final -- value of this accumulator together with the new list. -mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list -mapAccumR _ s [] = (s, []) -mapAccumR f s (x:xs) = (s'', y:ys) - where (s'',y ) = f s' x - (s', ys) = mapAccumR f s xs +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumR _ s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs -- | The 'insert' function takes an element and a list and inserts the -- element into the list at the last position where it is still less @@ -504,7 +522,7 @@ maximum :: (Ord a) => [a] -> a maximum [] = errorEmptyList "maximum" maximum xs = foldl1 max xs -{-# RULES +{-# RULES "maximumInt" maximum = (strictMaximum :: [Int] -> Int); "maximumInteger" maximum = (strictMaximum :: [Integer] -> Integer) #-} @@ -512,7 +530,7 @@ maximum xs = foldl1 max xs -- We can't make the overloaded version of maximum strict without -- changing its semantics (max might not be strict), but we can for -- the version specialised to 'Int'. -strictMaximum :: (Ord a) => [a] -> a +strictMaximum :: (Ord a) => [a] -> a strictMaximum [] = errorEmptyList "maximum" strictMaximum xs = foldl1' max xs @@ -529,7 +547,7 @@ minimum xs = foldl1 min xs "minimumInteger" minimum = (strictMinimum :: [Integer] -> Integer) #-} -strictMinimum :: (Ord a) => [a] -> a +strictMinimum :: (Ord a) => [a] -> a strictMinimum [] = errorEmptyList "minimum" strictMinimum xs = foldl1' min xs @@ -538,24 +556,24 @@ strictMinimum xs = foldl1' min xs -- | The 'maximumBy' function takes a comparison function and a list -- and returns the greatest element of the list by the comparison function. -- 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 - where - max x y = case cmp x y of - GT -> x - _ -> y +maximumBy :: (a -> a -> Ordering) -> [a] -> a +maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy cmp xs = foldl1 maxBy xs + where + 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 - where - min x y = case cmp x y of - GT -> y - _ -> x +minimumBy :: (a -> a -> Ordering) -> [a] -> a +minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy cmp xs = foldl1 minBy xs + where + 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,129 +582,138 @@ 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 :: (Integral i) => i -> [a] -> [a] +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 :: (Integral i) => i -> [a] -> [a] +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. genericIndex :: (Integral a) => [b] -> a -> b genericIndex (x:_) 0 = x -genericIndex (_:xs) n +genericIndex (_:xs) n | n > 0 = genericIndex xs (n-1) | otherwise = error "List.genericIndex: negative argument." genericIndex _ _ = error "List.genericIndex: index too large." -- | The 'genericReplicate' function is an overloaded version of 'replicate', -- which accepts any 'Integral' value as the number of repetitions to make. -genericReplicate :: (Integral i) => i -> a -> [a] -genericReplicate n x = genericTake n (repeat x) +genericReplicate :: (Integral i) => i -> a -> [a] +genericReplicate n x = genericTake n (repeat x) -- | The 'zip4' function takes four lists and returns a list of -- quadruples, analogous to 'zip'. -zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] -zip4 = zipWith4 (,,,) +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (,,,) -- | The 'zip5' function takes five lists and returns a list of -- five-tuples, analogous to 'zip'. -zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] -zip5 = zipWith5 (,,,,) +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (,,,,) -- | The 'zip6' function takes six lists and returns a list of six-tuples, -- analogous to 'zip'. -zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)] -zip6 = zipWith6 (,,,,,) +zip6 = zipWith6 (,,,,,) -- | The 'zip7' function takes seven lists and returns a list of -- seven-tuples, analogous to 'zip'. -zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)] -zip7 = zipWith7 (,,,,,,) +zip7 = zipWith7 (,,,,,,) -- | The 'zipWith4' function takes a function which combines four -- elements, as well as four lists and returns a list of their point-wise -- combination, analogous to 'zipWith'. -zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4 z as bs cs ds -zipWith4 _ _ _ _ _ = [] + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] -- | The 'zipWith5' function takes a function which combines five -- elements, as well as five lists and returns a list of their point-wise -- combination, analogous to 'zipWith'. -zipWith5 :: (a->b->c->d->e->f) -> +zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f] zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) - = z a b c d e : zipWith5 z as bs cs ds es -zipWith5 _ _ _ _ _ _ = [] + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] -- | The 'zipWith6' function takes a function which combines six -- elements, as well as six lists and returns a list of their point-wise -- combination, analogous to 'zipWith'. -zipWith6 :: (a->b->c->d->e->f->g) -> +zipWith6 :: (a->b->c->d->e->f->g) -> [a]->[b]->[c]->[d]->[e]->[f]->[g] zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) - = z a b c d e f : zipWith6 z as bs cs ds es fs -zipWith6 _ _ _ _ _ _ _ = [] + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] -- | The 'zipWith7' function takes a function which combines seven -- elements, as well as seven lists and returns a list of their point-wise -- combination, analogous to 'zipWith'. -zipWith7 :: (a->b->c->d->e->f->g->h) -> +zipWith7 :: (a->b->c->d->e->f->g->h) -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) - = z a b c d e f g : zipWith7 z as bs cs ds es fs gs + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs zipWith7 _ _ _ _ _ _ _ _ = [] -- | The 'unzip4' function takes a list of quadruples and returns four -- lists, analogous to 'unzip'. -unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) -unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> - (a:as,b:bs,c:cs,d:ds)) - ([],[],[],[]) +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) -- | The 'unzip5' function takes a list of five-tuples and returns five -- lists, analogous to 'unzip'. -unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) -unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> - (a:as,b:bs,c:cs,d:ds,e:es)) - ([],[],[],[],[]) +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) -- | The 'unzip6' function takes a list of six-tuples and returns six -- lists, analogous to 'unzip'. -unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) -unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> - (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) - ([],[],[],[],[],[]) +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) -- | The 'unzip7' function takes a list of seven-tuples and returns -- seven lists, analogous to 'unzip'. -unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) -unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> - (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) - ([],[],[],[],[],[],[]) +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) -- | The 'deleteFirstsBy' function takes a predicate and two lists and @@ -703,13 +730,13 @@ deleteFirstsBy eq = foldl (flip (deleteBy eq)) -- -- It is a special case of 'groupBy', which allows the programmer to supply -- their own equality test. -group :: Eq a => [a] -> [[a]] +group :: Eq a => [a] -> [[a]] group = groupBy (==) -- | The 'groupBy' function is the non-overloaded version of 'group'. -groupBy :: (a -> a -> Bool) -> [a] -> [[a]] -groupBy _ [] = [] -groupBy eq (x:xs) = (x:ys) : groupBy eq zs +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy _ [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs where (ys,zs) = span (eq x) xs -- | The 'inits' function returns all initial segments of the argument, @@ -717,18 +744,53 @@ groupBy eq (x:xs) = (x:ys) : groupBy eq zs -- -- > inits "abc" == ["","a","ab","abc"] -- -inits :: [a] -> [[a]] -inits [] = [[]] -inits (x:xs) = [[]] ++ map (x:) (inits xs) +-- Note that 'inits' has the following strictness property: +-- @inits _|_ = [] : _|_@ +inits :: [a] -> [[a]] +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",""] -- -tails :: [a] -> [[a]] -tails [] = [[]] -tails xxs@(_:xs) = xxs : tails xs +-- Note that 'tails' has the following strictness property: +-- @tails _|_ = _|_ : _|_@ +tails :: [a] -> [[a]] +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] @@ -834,7 +936,7 @@ qpart cmp x [] rlt rge r = rqsort cmp rlt (x:rqsort cmp rge r) qpart cmp x (y:ys) rlt rge r = case cmp x y of - GT -> qpart cmp x ys (y:rlt) rge r + GT -> qpart cmp x ys (y:rlt) rge r _ -> qpart cmp x ys rlt (y:rge) r -- rqsort is as qsort but anti-stable, i.e. reverses equal elements @@ -848,8 +950,8 @@ rqpart cmp x [] rle rgt r = qsort cmp rle (x:qsort cmp rgt r) rqpart cmp x (y:ys) rle rgt r = case cmp y x of - GT -> rqpart cmp x ys rle (y:rgt) r - _ -> rqpart cmp x ys (y:rle) rgt r + GT -> rqpart cmp x ys rle (y:rgt) r + _ -> rqpart cmp x ys (y:rle) rgt r -} #endif /* USE_REPORT_PRELUDE */ @@ -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 @@ -922,14 +1024,14 @@ sum :: (Num a) => [a] -> a -- | The 'product' function computes the product of a finite list of numbers. product :: (Num a) => [a] -> a #ifdef USE_REPORT_PRELUDE -sum = foldl (+) 0 +sum = foldl (+) 0 product = foldl (*) 1 #else -sum l = sum' l 0 +sum l = sum' l 0 where sum' [] a = a sum' (x:xs) a = sum' xs (a+x) -product l = prod l 1 +product l = prod l 1 where prod [] a = a prod (x:xs) a = prod xs (a*x) @@ -940,18 +1042,31 @@ product l = prod l 1 -- | 'lines' breaks a string up into a list of strings at newline -- characters. The resulting strings do not contain newlines. -lines :: String -> [String] -lines "" = [] -lines s = let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines s'' +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. -unlines :: [String] -> String +unlines :: [String] -> String #ifdef USE_REPORT_PRELUDE -unlines = concatMap (++ "\n") +unlines = concatMap (++ "\n") #else -- HBC version (stolen) -- here's a more efficient version @@ -961,25 +1076,25 @@ unlines (l:ls) = l ++ '\n' : unlines ls -- | 'words' breaks a string up into a list of words, which were delimited -- by white space. -words :: String -> [String] -words s = case dropWhile {-partain:Char.-}isSpace s of - "" -> [] - s' -> w : words s'' - where (w, s'') = +words :: String -> [String] +words s = case dropWhile {-partain:Char.-}isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = break {-partain:Char.-}isSpace s' -- | 'unwords' is an inverse operation to 'words'. -- It joins words with separating spaces. -unwords :: [String] -> String +unwords :: [String] -> String #ifdef USE_REPORT_PRELUDE -unwords [] = "" -unwords ws = foldr1 (\w s -> w ++ ' ':s) ws +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws #else -- HBC version (stolen) -- here's a more efficient version -unwords [] = "" -unwords [w] = w -unwords (w:ws) = w ++ ' ' : unwords ws +unwords [] = "" +unwords [w] = w +unwords (w:ws) = w ++ ' ' : unwords ws #endif #else /* !__GLASGOW_HASKELL__ */