[Git][ghc/ghc][master] Implement Data.List.compareLength and Data.List.NonEmpty.compareLength
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Jun 27 01:51:19 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
caf44a2d by Andrew Lelechenko at 2024-06-26T21:50:30-04:00
Implement Data.List.compareLength and Data.List.NonEmpty.compareLength
`compareLength xs n` is a safer and faster alternative to `compare (length xs) n`.
The latter would force and traverse the entire spine (potentially diverging),
while the former traverses as few elements as possible.
The implementation is carefully designed to maintain as much laziness as possible.
As per https://github.com/haskell/core-libraries-committee/issues/257
- - - - -
11 changed files:
- libraries/base/changelog.md
- libraries/base/src/Data/List.hs
- libraries/base/src/Data/List/NonEmpty.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- + testsuite/tests/lib/base/CompareLength.hs
- + testsuite/tests/lib/base/CompareLength.stdout
- testsuite/tests/lib/base/Unsnoc.hs
- testsuite/tests/lib/base/all.T
Changes:
=====================================
libraries/base/changelog.md
=====================================
@@ -2,6 +2,7 @@
## 4.21.0.0 *TBA*
* Add a `readTixFile` field to the `HpcFlags` record in `GHC.RTS.Flags` ([CLC proposal #276](https://github.com/haskell/core-libraries-committee/issues/276))
+ * Add `compareLength` to `Data.List` and `Data.List.NonEmpty` ([CLC proposal #257](https://github.com/haskell/core-libraries-committee/issues/257))
* Add `INLINE[1]` to `compareInt` / `compareWord` ([CLC proposal #179](https://github.com/haskell/core-libraries-committee/issues/179))
* Add the `MonadFix` instance for `(,) a`, similar to the one for `Writer a` ([CLC proposal #238](https://github.com/haskell/core-libraries-committee/issues/238))
* Improve `toInteger :: Word32 -> Integer` on 64-bit platforms ([CLC proposal #259](https://github.com/haskell/core-libraries-committee/issues/259))
=====================================
libraries/base/src/Data/List.hs
=====================================
@@ -26,6 +26,7 @@ module Data.List
singleton,
null,
length,
+ compareLength,
-- * List transformations
map,
reverse,
@@ -178,8 +179,12 @@ module Data.List
genericReplicate
) where
+import GHC.Internal.Data.Bool (otherwise)
import GHC.Internal.Data.List
import GHC.Internal.Data.List.NonEmpty (NonEmpty(..))
+import GHC.Internal.Data.Ord (Ordering(..), (<), (>))
+import GHC.Internal.Int (Int)
+import GHC.Internal.Num ((-))
import GHC.List (build)
inits1, tails1 :: [a] -> [NonEmpty a]
@@ -243,3 +248,37 @@ tails1 lst = build (\c n ->
let tails1Go [] = n
tails1Go (x : xs) = (x :| xs) `c` tails1Go xs
in tails1Go lst)
+
+-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative
+-- to 'compare' ('length' @xs@) @n at . Similarly, it's better
+-- to write @compareLength xs 10 == LT@ instead of @length xs < 10 at .
+--
+-- While 'length' would force and traverse
+-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite),
+-- 'compareLength' traverses at most @n@ elements to determine its result.
+--
+-- >>> compareLength [] 0
+-- EQ
+-- >>> compareLength [] 1
+-- LT
+-- >>> compareLength ['a'] 1
+-- EQ
+-- >>> compareLength ['a', 'b'] 1
+-- GT
+-- >>> compareLength [0..] 100
+-- GT
+-- >>> compareLength undefined (-1)
+-- GT
+-- >>> compareLength ('a' : undefined) 0
+-- GT
+--
+-- @since 4.21.0.0
+--
+compareLength :: [a] -> Int -> Ordering
+compareLength xs n
+ | n < 0 = GT
+ | otherwise = foldr
+ (\_ f m -> if m > 0 then f (m - 1) else GT)
+ (\m -> if m > 0 then LT else EQ)
+ xs
+ n
=====================================
libraries/base/src/Data/List/NonEmpty.hs
=====================================
@@ -36,6 +36,7 @@ module Data.List.NonEmpty (
, sortWith -- :: Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
-- * Basic functions
, length -- :: NonEmpty a -> Int
+ , compareLength -- :: NonEmpty a -> Int -> Ordering
, head -- :: NonEmpty a -> a
, tail -- :: NonEmpty a -> [a]
, last -- :: NonEmpty a -> a
@@ -128,6 +129,36 @@ infixr 5 <|
length :: NonEmpty a -> Int
length (_ :| xs) = 1 + Prelude.length xs
+-- | Use 'compareLength' @xs@ @n@ as a safer and faster alternative
+-- to 'compare' ('length' @xs@) @n at . Similarly, it's better
+-- to write @compareLength xs 10 == LT@ instead of @length xs < 10 at .
+--
+-- While 'length' would force and traverse
+-- the entire spine of @xs@ (which could even diverge if @xs@ is infinite),
+-- 'compareLength' traverses at most @n@ elements to determine its result.
+--
+-- >>> compareLength ('a' :| []) 1
+-- EQ
+-- >>> compareLength ('a' :| ['b']) 3
+-- LT
+-- >>> compareLength (0 :| [1..]) 100
+-- GT
+-- >>> compareLength undefined 0
+-- GT
+-- >>> compareLength ('a' :| 'b' : undefined) 1
+-- GT
+--
+-- @since 4.21.0.0
+--
+compareLength :: NonEmpty a -> Int -> Ordering
+compareLength xs n
+ | n < 1 = GT
+ | otherwise = foldr
+ (\_ f m -> if m > 0 then f (m - 1) else GT)
+ (\m -> if m > 0 then LT else EQ)
+ xs
+ n
+
-- | Compute n-ary logic exclusive OR operation on 'NonEmpty' list.
xor :: NonEmpty Bool -> Bool
xor (x :| xs) = foldr xor' x xs
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1299,6 +1299,7 @@ module Data.List where
and :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
any :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
break :: forall a. (a -> GHC.Types.Bool) -> [a] -> ([a], [a])
+ compareLength :: forall a. [a] -> GHC.Types.Int -> GHC.Types.Ordering
concat :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t [a] -> [a]
concatMap :: forall (t :: * -> *) a b. GHC.Internal.Data.Foldable.Foldable t => (a -> [b]) -> t a -> [b]
cycle :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> [a]
@@ -1423,6 +1424,7 @@ module Data.List.NonEmpty where
append :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
appendList :: forall a. NonEmpty a -> [a] -> NonEmpty a
break :: forall a. (a -> GHC.Types.Bool) -> NonEmpty a -> ([a], [a])
+ compareLength :: forall a. NonEmpty a -> GHC.Types.Int -> GHC.Types.Ordering
cons :: forall a. a -> NonEmpty a -> NonEmpty a
cycle :: forall a. NonEmpty a -> NonEmpty a
drop :: forall a. GHC.Types.Int -> NonEmpty a -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1299,6 +1299,7 @@ module Data.List where
and :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
any :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
break :: forall a. (a -> GHC.Types.Bool) -> [a] -> ([a], [a])
+ compareLength :: forall a. [a] -> GHC.Types.Int -> GHC.Types.Ordering
concat :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t [a] -> [a]
concatMap :: forall (t :: * -> *) a b. GHC.Internal.Data.Foldable.Foldable t => (a -> [b]) -> t a -> [b]
cycle :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> [a]
@@ -1423,6 +1424,7 @@ module Data.List.NonEmpty where
append :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
appendList :: forall a. NonEmpty a -> [a] -> NonEmpty a
break :: forall a. (a -> GHC.Types.Bool) -> NonEmpty a -> ([a], [a])
+ compareLength :: forall a. NonEmpty a -> GHC.Types.Int -> GHC.Types.Ordering
cons :: forall a. a -> NonEmpty a -> NonEmpty a
cycle :: forall a. NonEmpty a -> NonEmpty a
drop :: forall a. GHC.Types.Int -> NonEmpty a -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1299,6 +1299,7 @@ module Data.List where
and :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
any :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
break :: forall a. (a -> GHC.Types.Bool) -> [a] -> ([a], [a])
+ compareLength :: forall a. [a] -> GHC.Types.Int -> GHC.Types.Ordering
concat :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t [a] -> [a]
concatMap :: forall (t :: * -> *) a b. GHC.Internal.Data.Foldable.Foldable t => (a -> [b]) -> t a -> [b]
cycle :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> [a]
@@ -1423,6 +1424,7 @@ module Data.List.NonEmpty where
append :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
appendList :: forall a. NonEmpty a -> [a] -> NonEmpty a
break :: forall a. (a -> GHC.Types.Bool) -> NonEmpty a -> ([a], [a])
+ compareLength :: forall a. NonEmpty a -> GHC.Types.Int -> GHC.Types.Ordering
cons :: forall a. a -> NonEmpty a -> NonEmpty a
cycle :: forall a. NonEmpty a -> NonEmpty a
drop :: forall a. GHC.Types.Int -> NonEmpty a -> [a]
=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1299,6 +1299,7 @@ module Data.List where
and :: forall (t :: * -> *). GHC.Internal.Data.Foldable.Foldable t => t GHC.Types.Bool -> GHC.Types.Bool
any :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => (a -> GHC.Types.Bool) -> t a -> GHC.Types.Bool
break :: forall a. (a -> GHC.Types.Bool) -> [a] -> ([a], [a])
+ compareLength :: forall a. [a] -> GHC.Types.Int -> GHC.Types.Ordering
concat :: forall (t :: * -> *) a. GHC.Internal.Data.Foldable.Foldable t => t [a] -> [a]
concatMap :: forall (t :: * -> *) a b. GHC.Internal.Data.Foldable.Foldable t => (a -> [b]) -> t a -> [b]
cycle :: forall a. GHC.Internal.Stack.Types.HasCallStack => [a] -> [a]
@@ -1423,6 +1424,7 @@ module Data.List.NonEmpty where
append :: forall a. NonEmpty a -> NonEmpty a -> NonEmpty a
appendList :: forall a. NonEmpty a -> [a] -> NonEmpty a
break :: forall a. (a -> GHC.Types.Bool) -> NonEmpty a -> ([a], [a])
+ compareLength :: forall a. NonEmpty a -> GHC.Types.Int -> GHC.Types.Ordering
cons :: forall a. a -> NonEmpty a -> NonEmpty a
cycle :: forall a. NonEmpty a -> NonEmpty a
drop :: forall a. GHC.Types.Int -> NonEmpty a -> [a]
=====================================
testsuite/tests/lib/base/CompareLength.hs
=====================================
@@ -0,0 +1,21 @@
+module Main (main) where
+
+import qualified Data.List as L
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NE
+
+main :: IO ()
+main = do
+ print $ L.compareLength [] 0
+ print $ L.compareLength [] 1
+ print $ L.compareLength ['a'] 1
+ print $ L.compareLength ['a', 'b'] 1
+ print $ L.compareLength [0..] 100
+ print $ L.compareLength undefined (-1)
+ print $ L.compareLength ('a' : undefined) 0
+
+ print $ NE.compareLength ('a' :| []) 1
+ print $ NE.compareLength ('a' :| ['b']) 3
+ print $ NE.compareLength (0 :| [1..]) 100
+ print $ NE.compareLength undefined 0
+ print $ NE.compareLength ('a' :| 'b' : undefined) 1
=====================================
testsuite/tests/lib/base/CompareLength.stdout
=====================================
@@ -0,0 +1,12 @@
+EQ
+LT
+EQ
+GT
+GT
+GT
+GT
+EQ
+LT
+GT
+GT
+GT
=====================================
testsuite/tests/lib/base/Unsnoc.hs
=====================================
@@ -1,6 +1,6 @@
{-# OPTIONS_GHC -Wno-x-partial #-}
-module Main (main) where
+module Main (main) where
import Data.List (unsnoc)
=====================================
testsuite/tests/lib/base/all.T
=====================================
@@ -13,3 +13,4 @@ test('First-Semigroup-sconcat', normal, compile_and_run, [''])
test('First-Monoid-sconcat', normal, compile_and_run, [''])
test('Sort', normal, compile_and_run, [''])
test('InitsTails', normal, compile_and_run, [''])
+test('CompareLength', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/caf44a2ddfe007e840f6f212d3445d1cfe5c063e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/caf44a2ddfe007e840f6f212d3445d1cfe5c063e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240626/ddd63cdc/attachment-0001.html>
More information about the ghc-commits
mailing list