SafeHaskell: Added SafeHaskell to base
[packages/base.git] / Data / List.hs
index ebee0f1..4f76c83 100644 (file)
@@ -1,4 +1,6 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.List
@@ -230,10 +232,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)
@@ -297,12 +299,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
@@ -410,6 +412,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
@@ -420,8 +424,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
@@ -733,19 +745,24 @@ 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.
 --
@@ -793,10 +810,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 <igloo@earth.li>
@@ -837,7 +894,6 @@ 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
@@ -863,8 +919,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]
@@ -988,10 +1045,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.