[Git][ghc/ghc][wip/Data.List.compareLength] Implement Data.List.compareLength and Data.List.NonEmpty.compareLength

Bodigrim (@Bodigrim) gitlab at gitlab.haskell.org
Mon Jun 24 19:36:56 UTC 2024 


Bodigrim pushed to branch wip/Data.List.compareLength at Glasgow Haskell Compiler / GHC


Commits:
39c40e6c by Andrew Lelechenko at 2024-06-24T20:36:41+01: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/39c40e6c49ca8deaac7fd00fbd325520f5f0f6d3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/39c40e6c49ca8deaac7fd00fbd325520f5f0f6d3
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/20240624/430c1fc6/attachment-0001.html>

More information about the ghc-commits mailing list