-{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Data.List
, intersperse -- :: a -> [a] -> [a]
, intercalate -- :: [a] -> [[a]] -> [a]
, transpose -- :: [[a]] -> [[a]]
+
+ , subsequences -- :: [a] -> [[a]]
+ , permutations -- :: [a] -> [[a]]
-- * Reducing lists (folds)
-- 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)
--
-- 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
-- '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
-- > [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.
-- | 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
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
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
{-# 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)
-- 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
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.
--
-- > 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)
------------------------------------------------------------------------------
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 <igloo@earth.li>
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
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]
-- | 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
-- 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.
projects / ghc-base.git / blobdiff