add GHC.HetMet.{hetmet_kappa,hetmet_kappa_app}

[ghc-base.git] / Data / List.hs

diff --git a/Data/List.hs b/Data/List.hs
index 012c177..bb71da5 100644 (file)
--- a/Data/List.hs
+++ b/Data/List.hs
@@ -1,4 +1,5 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+

 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.List
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.List

@@ -230,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.
 --
 -- 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)
 stripPrefix :: Eq a => [a] -> [a] -> Maybe [a]
 stripPrefix [] ys = Just ys
 stripPrefix (x:xs) (y:ys)

@@ -297,12 +298,12 @@ isSuffixOf x y          =  reverse x `isPrefixOf` reverse y
 --
 -- Example:
 --
 --
 -- 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)
 
 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
 -- 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

@@ -342,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
 -- '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
 
 
 #endif
 
 

@@ -399,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,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.
 
 -- It is a special case of 'intersectBy', which allows the programmer to
 -- supply their own equality test.
 

@@ -407,6 +411,8 @@ intersect               =  intersectBy (==)
 
 -- | The 'intersectBy' function is the non-overloaded version of 'intersect'.
 intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 
 -- | 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
 intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]
 
 -- | The 'intersperse' function takes an element and a list and

@@ -417,8 +423,16 @@ intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]
 
 intersperse             :: a -> [a] -> [a]
 intersperse _   []      = []
 
 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
 
 -- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@.
 -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the

@@ -434,7 +448,7 @@ intercalate xs xss = concat (intersperse xs xss)
 transpose               :: [[a]] -> [[a]]
 transpose []             = []
 transpose ([]   : xss)   = transpose 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
 
 
 -- | The 'partition' function takes a predicate a list and returns

@@ -447,6 +461,7 @@ partition               :: (a -> Bool) -> [a] -> ([a],[a])
 {-# INLINE partition #-}
 partition p xs = foldr (select p) ([],[]) xs
 
 {-# 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)
 
 select p x ~(ts,fs) | p x       = (x:ts,fs)
                     | otherwise = (ts, x:fs)
 

@@ -543,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"
 -- 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
                         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"
 
 -- | 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
                         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
 
 -- | The 'genericLength' function is an overloaded version of 'length'.  In
 -- particular, instead of returning an 'Int', it returns any type which is

@@ -567,30 +582,39 @@ genericLength           :: (Num i) => [b] -> i
 genericLength []        =  0
 genericLength (_:l)     =  1 + genericLength l
 
 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]
 -- | 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 _ []        =  []

-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]
 
 -- | 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 _ []        =  []

-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])
 
 -- | 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 _ []     =  ([],[])

-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.
 
 -- | The 'genericIndex' function is an overloaded version of '!!', which
 -- accepts any 'Integral' value as the index.

@@ -720,19 +744,24 @@ groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs
 --
 -- > inits "abc" == ["","a","ab","abc"]
 --
 --
 -- > inits "abc" == ["","a","ab","abc"]
 --

+-- Note that 'inits' has the following strictness property:
+-- @inits _|_ = [] : _|_@

 inits                   :: [a] -> [[a]]
 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",""]
 --
 
 -- | 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                   :: [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.
 --
 
 -- | The 'subsequences' function returns the list of all subsequences of the argument.
 --

@@ -754,12 +783,12 @@ nonEmptySubsequences (x:xs)  =  [x] : foldr f [] (nonEmptySubsequences xs)
 --
 -- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"]
 permutations            :: [a] -> [[a]]
 --
 -- > permutations "abc" == ["abc","bac","cba","bca","cab","acb"]
 permutations            :: [a] -> [[a]]

-permutations xs         =  xs : perms xs []
+permutations xs0        =  xs0 : perms xs0 []

   where
   where

-    perms []     is = []
+    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
     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' f []     r = (ts, r)
+            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)
 
             interleave' f (y:ys) r = let (us,zs) = interleave' (f . (y:)) ys r
                                      in  (y:us, f (t:y:us) : zs)
 

@@ -780,10 +809,50 @@ sort = sortBy compare
 sortBy cmp = foldr (insertBy cmp) []
 #else
 
 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
 
 sortBy cmp l = mergesort cmp l
 sort l = mergesort compare l
 

-{-

 Quicksort replaced by mergesort, 14/5/2002.
 
 From: Ian Lynagh <igloo@earth.li>
 Quicksort replaced by mergesort, 14/5/2002.
 
 From: Ian Lynagh <igloo@earth.li>

@@ -824,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
 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 :: (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]]
 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_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
 merge cmp (x:xs) (y:ys)
  = case x `cmp` y of
         GT -> y : merge cmp (x:xs)   ys

@@ -850,8 +918,9 @@ merge cmp (x:xs) (y:ys)
 wrap :: a -> [a]
 wrap x = [x]
 
 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]
 
 -- qsort is stable and does not concatenate.
 qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]

@@ -921,7 +990,7 @@ unfoldr f b  =
 -- | A strict version of 'foldl'.
 foldl'           :: (a -> b -> a) -> a -> [b] -> a
 #ifdef __GLASGOW_HASKELL__
 -- | 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
     where lgo z []     = z
           lgo z (x:xs) = let z' = f z x in z' `seq` lgo z' xs
 #else

@@ -975,10 +1044,23 @@ product l       = prod l 1
 -- characters.  The resulting strings do not contain newlines.
 lines                   :: String -> [String]
 lines ""                =  []
 -- 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''
 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' is an inverse operation to 'lines'.
 -- It joins lines, after appending a terminating newline to each.