Merge pull request #486 from exaexa/patch-1

do not drop extra elements in Data.List.Linear drop and take

Author: aspiwack

.github/workflows/ci.yaml

@@ -13,12 +13,12 @@ jobs:
         ghc-version: [96, 98, 910]
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v4
     - uses: cachix/install-nix-action@v15
       with:
         nix_path: "${{ env.nixpkgs-url }}"
     - name: Cache Cabal dependencies
-      uses: actions/cache@v2
+      uses: actions/cache@v4
       with:
         path: |
           ~/.cabal/packages
@@ -45,7 +45,7 @@ jobs:
     - name: Run benchmarks
       run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal bench 2>&1 | tee benchmark_ghc${{ matrix.ghc-version }}.txt"
     - name: Upload benchmark results
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: linear-base_benchmarks_ghc${{ matrix.ghc-version }}
         path: |
@@ -56,12 +56,12 @@ jobs:
     name: check formatting with ormolu
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v4
     - uses: cachix/install-nix-action@v15
       with:
         nix_path: "${{ env.nixpkgs-url }}"
     - name: Cache Stack dependencies
-      uses: actions/cache@v2
+      uses: actions/cache@v4
       with:
         path: ~/.stack
         key: stack-deps-ormolu-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('stack.yaml.lock') }}-${{ github.sha }}
@@ -75,12 +75,12 @@ jobs:
     name: stack build
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v4
     - uses: cachix/install-nix-action@v15
       with:
         nix_path: "${{ env.nixpkgs-url }}"
     - name: Cache Stack dependencies
-      uses: actions/cache@v2
+      uses: actions/cache@v4
       with:
         path: ~/.stack
         key: stack-deps-${{ runner.os }}-${{ hashFiles('nix/sources.json') }}-v${{ env.cache-invalidation-key }}-${{ hashFiles('stack.yaml.lock', 'linear-base.cabal') }}-${{ github.sha }}

linear-base.cabal

@@ -170,14 +170,15 @@ test-suite test
     hs-source-dirs:   test
     other-modules:
         Test.Data.Destination
+        Test.Data.Functor.Linear
+        Test.Data.List
         Test.Data.Mutable.Array
-        Test.Data.Mutable.Vector
         Test.Data.Mutable.HashMap
         Test.Data.Mutable.Set
+        Test.Data.Mutable.Vector
         Test.Data.Polarized
-        Test.Data.Functor.Linear
-        Test.Data.V
         Test.Data.Replicator
+        Test.Data.V
     default-language: Haskell2010
     build-depends:
         inspection-testing,

src/Data/List/Linear.hs

@@ -191,13 +191,13 @@ dropWhile p (x : xs) =
 take :: (Consumable a) => Int -> [a] %1 -> [a]
 take _ [] = []
 take i (x : xs)
-  | i Prelude.< 0 = (x, xs) `lseq` []
+  | i Prelude.<= 0 = (x, xs) `lseq` []
   | otherwise = x : take (i - 1) xs
 
 drop :: (Consumable a) => Int -> [a] %1 -> [a]
 drop _ [] = []
 drop i (x : xs)
-  | i Prelude.< 0 = x : xs
+  | i Prelude.<= 0 = x : xs
   | otherwise = x `lseq` drop (i - 1) xs
 
 -- | The intersperse function takes an element and a list and

test/Main.hs

@@ -5,6 +5,7 @@ module Main where
 
 import Test.Data.Destination (destArrayTests)
 import Test.Data.Functor.Linear (genericTests)
+import Test.Data.List (listTests)
 import Test.Data.Mutable.Array (mutArrTests)
 import Test.Data.Mutable.HashMap (mutHMTests)
 import Test.Data.Mutable.Set (mutSetTests)
@@ -29,6 +30,7 @@ allTests =
           mutSetTests,
           destArrayTests,
           polarizedArrayTests,
+          listTests,
           genericTests
         ],
       testGroup

test/Test/Data/List.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Test.Data.List (listTests) where
+
+import qualified Data.List.Linear as List
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import Prelude.Linear
+import Test.Tasty
+import Test.Tasty.Hedgehog (testPropertyNamed)
+import qualified Prelude
+
+listTests :: TestTree
+listTests =
+  testGroup
+    "List tests"
+    [ testPropertyNamed "take n ++ drop n = id" "take_drop" take_drop,
+      testPropertyNamed "length . take n = const n" "take_length" take_length
+    ]
+
+take_drop :: Property
+take_drop = property $ do
+  n <- forAll $ Gen.int (Range.linear 0 50)
+  classify "0" $ n == 0
+  xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 40))
+  classify "length > n" $ Prelude.length xs > n
+  List.take n xs ++ List.drop n xs === xs
+
+take_length :: Property
+take_length = property $ do
+  n <- forAll $ Gen.int (Range.linear 0 50)
+  classify "0" $ n == 0
+  xs <- forAll $ Gen.list (Range.linear 0 1000) (Gen.int (Range.linear 0 40))
+  classify "length > n" $ Prelude.length xs > n
+  case Prelude.length xs > n of
+    True -> do
+      annotate "Prelude.length xs > n"
+      Prelude.length (List.take n xs) === n
+    False -> do
+      annotate "Prelude.length xs < n"
+      Prelude.length (List.take n xs) === Prelude.length xs