Merge pull request #319 from recursion-ninja/ghc-9.10

mheinzel · web-flow · commit 639bfbfc81d8 · 2024-08-12T09:30:26.000Z
Minor refactoring to add compatability with GHC 9.10
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -22,7 +22,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ["8.10.7", "9.2.8", "9.4.8", "9.6.4", "9.8.2"]
+        ghc: ["8.10.7", "9.2.8", "9.4.8", "9.6.4", "9.8.2", "9.10.1"]
         cabal: ["3.10.2.1"]
         os: [ubuntu-latest, windows-latest, macOS-latest]
         cabal-flags: [""]
@@ -38,6 +38,10 @@ jobs:
             os: windows-latest
           - ghc: "9.8.2"
             os: macOS-latest
+          - ghc: "9.10.1"
+            os: windows-latest
+          - ghc: "9.10.1"
+            os: macOS-latest
         include:
           - ghc: "8.10.7"
             cabal: "3.10.2.1"
diff --git a/bench/macro/lsm-tree-bench-bloomfilter.hs b/bench/macro/lsm-tree-bench-bloomfilter.hs
@@ -13,7 +13,7 @@ import           Data.BloomFilter (Bloom)
 import qualified Data.BloomFilter as Bloom
 import qualified Data.BloomFilter.Hash as Bloom
 import qualified Data.BloomFilter.Mutable as MBloom
-import           Data.List (foldl')
+import qualified Data.Foldable as Fold
 import           Data.Time
 import           Data.Vector (Vector)
 import qualified Data.Vector as Vector
@@ -264,6 +264,6 @@ benchElemCheapHashes !bs !rng !n =
     let k :: Word256
         (!k, !rng') = uniform rng
         !kh =  Bloom.makeHashes (serialiseKey k)
-     in foldl' (\_ b -> Bloom.elemHashes kh b `seq` ()) () bs
+     in Fold.foldl' (\_ b -> Bloom.elemHashes kh b `seq` ()) () bs
   `seq` benchElemCheapHashes bs rng' (n-1)
 
diff --git a/bench/macro/lsm-tree-bench-wp8.hs b/bench/macro/lsm-tree-bench-wp8.hs
@@ -48,9 +48,9 @@ import           Control.Monad (forM_, unless, void, when)
 import qualified Crypto.Hash.SHA256 as SHA256
 import qualified Data.Binary as B
 import qualified Data.ByteString.Short as BS
+import qualified Data.Foldable as Fold
 import qualified Data.IntSet as IS
 import           Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)
-import           Data.List (foldl')
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Traversable (mapAccumL)
@@ -762,7 +762,7 @@ pureReference !initialSize !batchSize !batchCount !seed =
       where
         (g', lookups, inserts) = generateBatch initialSize batchSize g b
         !results = V.map (lookup m) lookups
-        !m'      = foldl' (flip (uncurry Map.insert)) m inserts
+        !m'      = Fold.foldl' (flip (uncurry Map.insert)) m inserts
 
     lookup m k =
       case Map.lookup k m of
diff --git a/bench/micro/Bench/Database/LSMTree/Internal/BloomFilter.hs b/bench/micro/Bench/Database/LSMTree/Internal/BloomFilter.hs
@@ -14,7 +14,7 @@ import           Data.BloomFilter (Bloom)
 import qualified Data.BloomFilter as Bloom
 import qualified Data.BloomFilter.Easy as Bloom.Easy
 import           Data.BloomFilter.Hash (Hashable)
-import           Data.Foldable (Foldable (..))
+import qualified Data.Foldable as Fold
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Database.LSMTree.Extras.Random
@@ -62,7 +62,7 @@ elemEnv fpr nbloom nelemsPositive nelemsNegative = do
 
 -- | Used for benchmarking 'Bloom.elem'.
 elems :: Hashable a => Bloom a -> [a] -> ()
-elems b xs = foldl' (\acc x -> Bloom.elem x b `seq` acc) () xs
+elems b xs = Fold.foldl' (\acc x -> Bloom.elem x b `seq` acc) () xs
 
 -- | Input environment for benchmarking 'constructBloom'.
 constructionEnv :: Int -> IO (Map SerialisedKey SerialisedKey)
diff --git a/bench/micro/Bench/Database/LSMTree/Internal/IndexCompact.hs b/bench/micro/Bench/Database/LSMTree/Internal/IndexCompact.hs
@@ -13,7 +13,7 @@ import           Control.DeepSeq (deepseq)
 import           Control.Exception (assert)
 import           Control.Monad.ST.Strict
 import           Criterion.Main
-import           Data.Foldable (Foldable (..))
+import qualified Data.Foldable as Fold
 import qualified Data.List as List
 import           Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
@@ -63,7 +63,7 @@ searches ::
      IndexCompact
   -> [SerialisedKey]            -- ^ Keys to search for
   -> ()
-searches ic ks = foldl' (\acc k -> search k ic `deepseq` acc) () ks
+searches ic ks = Fold.foldl' (\acc k -> search k ic `deepseq` acc) () ks
 
 -- | Input environment for benchmarking 'constructIndexCompact'.
 constructionEnv ::
diff --git a/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs b/bench/micro/Bench/Database/LSMTree/Internal/Merge.hs
@@ -6,6 +6,7 @@ import qualified Criterion.Main as Cr
 import           Data.Bifunctor (first)
 import qualified Data.BloomFilter.Hash as Hash
 import           Data.Foldable (traverse_)
+import qualified Data.Foldable as Fold
 import qualified Data.List as List
 import           Data.Maybe (fromMaybe)
 import           Data.Word (Word64)
@@ -362,7 +363,7 @@ createRun ::
   -> IO (Run (FS.Handle h))
 createRun hasFS hasBlockIO mMappend targetPath =
       Run.fromWriteBuffer hasFS  hasBlockIO Run.CacheRunData (RunAllocFixed 10) targetPath
-    . List.foldl insert WB.empty
+    . Fold.foldl insert WB.empty
   where
     insert wb (k, e) = case mMappend of
       Nothing -> WB.addEntryNormal k (expectNormal e) wb
diff --git a/bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs b/bench/micro/Bench/Database/LSMTree/Internal/WriteBuffer.hs
@@ -4,6 +4,7 @@ import           Control.DeepSeq (NFData (..))
 import           Criterion.Main (Benchmark, bench, bgroup)
 import qualified Criterion.Main as Cr
 import           Data.Bifunctor (first)
+import qualified Data.Foldable as Fold
 import qualified Data.List as List
 import           Data.Maybe (fromMaybe)
 import           Data.Word (Word64)
@@ -157,9 +158,9 @@ benchWriteBuffer conf@Config{name} =
 
 insert :: InputKOps -> WriteBuffer
 insert (NormalInputs kops) =
-    List.foldl' (\wb (k, e) -> WB.addEntryNormal k e wb) WB.empty kops
+    Fold.foldl' (\wb (k, e) -> WB.addEntryNormal k e wb) WB.empty kops
 insert (MonoidalInputs kops mappendVal) =
-    List.foldl' (\wb (k, e) -> WB.addEntryMonoidal mappendVal k e wb) WB.empty kops
+    Fold.foldl' (\wb (k, e) -> WB.addEntryMonoidal mappendVal k e wb) WB.empty kops
 
 flush :: FS.HasFS IO FS.HandleIO
       -> FS.HasBlockIO IO FS.HandleIO
diff --git a/blockio-sim/src/System/FS/BlockIO/Sim.hs b/blockio-sim/src/System/FS/BlockIO/Sim.hs
@@ -56,7 +56,7 @@ simErrorHasBlockIO ::
   -> StrictTVar m Errors
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simErrorHasBlockIO fsVar errorsVar = do
-    let hfs = mkSimErrorHasFS fsVar errorsVar
+    let hfs = simErrorHasFS fsVar errorsVar
     hbio <- fromHasFS hfs
     pure (hfs, hbio)
 
@@ -66,6 +66,6 @@ simErrorHasBlockIO' ::
   -> Errors
   -> m (HasFS m HandleMock, HasBlockIO m HandleMock)
 simErrorHasBlockIO' mockFS errs = do
-    hfs <- mkSimErrorHasFS' mockFS errs
+    hfs <- simErrorHasFS' mockFS errs
     hbio <- fromHasFS hfs
     pure (hfs, hbio)
diff --git a/cabal.project b/cabal.project
@@ -12,11 +12,11 @@ repository cardano-haskell-packages
 
 index-state:
   -- Bump this if you need newer packages from Hackage
-  -- current date: crc32c-0.2.2
-  , hackage.haskell.org 2024-06-05T04:25:30Z
+  -- current date: support ghc-9.10.1
+  , hackage.haskell.org 2024-08-01T00:00:00Z
   -- Bump this if you need newer packages from CHaP
-  -- current date: fs-api-0.2.0.1, fs-sim-0.2.1.1
-  , cardano-haskell-packages 2023-11-30T09:59:24Z
+  -- current date: support ghc-9.10.1
+  , cardano-haskell-packages 2024-08-01T00:00:00Z
 
 packages: .
 
@@ -44,7 +44,13 @@ import: cabal.project.blockio-uring
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/fs-sim
-  tag: 47879aa5edfd3a3f8824d61687e85b8f1586e010
+  tag: 235d5dd10aadb70defa5a2e843a4cadf5d6eb18e
   subdir:
     fs-api
     fs-sim
+
+-- TODO: this relaxing of dependency bounds on @base@ is currently required in order to
+-- build the Haddock documentation with the @scripts/haddock.sh@ script.
+if impl(ghc >=9.10)
+  allow-newer:
+    quickcheck-lockstep:base,
diff --git a/lsm-tree.cabal b/lsm-tree.cabal
@@ -12,7 +12,8 @@ category:           Database
 build-type:         Simple
 extra-doc-files:    CHANGELOG.md
 extra-source-files: README.md
-tested-with:        GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 || ==9.8
+tested-with:
+  GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10
 
 source-repository head
   type:     git
@@ -147,23 +148,23 @@ library
     Database.LSMTree.Normal
 
   build-depends:
-    , base                  >=4.14      && <4.20
+    , base                  >=4.14      && <4.21
     , bitvec                ^>=1.1
     , bytestring            ^>=0.11.4.0 || ^>=0.12.1.0
     , containers
     , crc32c                ^>=0.2.1
     , deepseq               ^>=1.4      || ^>=1.5
     , filepath
     , fs-api                ^>=0.2
-    , io-classes            ^>=1.4
+    , io-classes            ^>=1.5
     , lsm-tree:blockio-api
     , lsm-tree:bloomfilter
     , lsm-tree:kmerge
     , lsm-tree:monkey
     , nothunks              ^>=0.2
     , primitive             ^>=0.9
-    , strict-mvar           ^>=1.4
-    , strict-stm            ^>=1.4
+    , strict-mvar           ^>=1.5
+    , strict-stm            ^>=1.5
     , vector                ^>=0.13
     , vector-algorithms     ^>=0.9
 
@@ -336,8 +337,8 @@ test-suite lsm-tree-test
     , filepath
     , fs-api
     , fs-sim                   >=0.2
-    , io-classes
-    , io-sim                   >=1.4
+    , io-classes               >=1.5
+    , io-sim                   >=1.5
     , lsm-tree
     , lsm-tree:blockio-api
     , lsm-tree:blockio-sim
@@ -453,7 +454,7 @@ benchmark lsm-tree-bench-lookups
     , bytestring
     , deepseq
     , fs-api
-    , io-classes
+    , io-classes            >=1.5
     , lsm-tree
     , lsm-tree:blockio-api
     , lsm-tree:bloomfilter
@@ -571,7 +572,7 @@ test-suite kmerge-test
   hs-source-dirs: test
   main-is:        kmerge-test.hs
   build-depends:
-    , base              >=4.14 && <4.20
+    , base              >=4.14 && <4.21
     , deepseq
     , heaps
     , lsm-tree:kmerge
@@ -590,7 +591,7 @@ benchmark kmerge-bench
   main-is:        kmerge-test.hs
   cpp-options:    -DKMERGE_BENCHMARKS
   build-depends:
-    , base              >=4.14 && <4.20
+    , base              >=4.14 && <4.21
     , deepseq
     , heaps
     , lsm-tree:kmerge
@@ -608,7 +609,7 @@ test-suite map-range-test
   hs-source-dirs: test
   main-is:        map-range-test.hs
   build-depends:
-    , base              >=4.14 && <4.20
+    , base              >=4.14 && <4.21
     , bytestring
     , containers
     , lsm-tree
@@ -669,10 +670,10 @@ library blockio-api
     System.FS.BlockIO.Serial
 
   build-depends:
-    , base        >=4.14  && <4.20
+    , base        >=4.14  && <4.21
     , deepseq     ^>=1.4  || ^>=1.5
     , fs-api      ^>=0.2
-    , io-classes  ^>=1.4
+    , io-classes  ^>=1.5
     , primitive   ^>=0.9
     , vector      ^>=0.13
 
@@ -706,7 +707,7 @@ test-suite blockio-api-test
   main-is:        Main.hs
   build-depends:
     , async
-    , base                  >=4.14 && <4.20
+    , base                  >=4.14 && <4.21
     , bytestring
     , fs-api
     , lsm-tree:blockio-api
@@ -725,13 +726,13 @@ library blockio-sim
   hs-source-dirs:  blockio-sim/src
   exposed-modules: System.FS.BlockIO.Sim
   build-depends:
-    , base                  >=4.14 && <4.20
+    , base                  >=4.14 && <4.21
     , fs-api                ^>=0.2
     , fs-sim                ^>=0.2
-    , io-classes            ^>=1.4
+    , io-classes            ^>=1.5
     , lsm-tree:blockio-api
     , primitive             ^>=0.9
-    , strict-stm            ^>=1.4
+    , strict-stm            ^>=1.5
 
 library fcntl-nocache
   import:         language, warnings
diff --git a/prototypes/FormatPage.hs b/prototypes/FormatPage.hs
@@ -54,7 +54,7 @@ module FormatPage (
 
 import           Data.Bits
 import           Data.Function (on)
-import           Data.List (foldl', nubBy, sortBy, unfoldr)
+import qualified Data.List as List
 import           Data.Maybe (fromJust, fromMaybe)
 import           Data.Word
 
@@ -476,9 +476,9 @@ toBitmap =
     map toWord64 . group64
   where
     toWord64 :: [Bool] -> Word64
-    toWord64 = foldl' (\w (n,b) -> if b then setBit w n else w) 0
+    toWord64 = List.foldl' (\w (n,b) -> if b then setBit w n else w) 0
              . zip [0 :: Int ..]
-    group64  = unfoldr (\xs -> if null xs
+    group64  = List.unfoldr (\xs -> if null xs
                                  then Nothing
                                  else Just (splitAt 64 xs))
 
@@ -525,7 +525,7 @@ pageDiskPages p =
 
 pageSerialisedChunks :: DiskPageSize -> PageSerialised -> [ByteString]
 pageSerialisedChunks dpgsz =
-    unfoldr (\p -> if BS.null p then Nothing
+    List.unfoldr (\p -> if BS.null p then Nothing
                                 else Just (BS.splitAt dpgszBytes p))
   where
     dpgszBytes = diskPageSizeBytes dpgsz
@@ -824,8 +824,8 @@ instance Arbitrary DiskPageSize where
 --
 orderdKeyOps :: [(Key, Operation)] -> [(Key, Operation)]
 orderdKeyOps =
-    nubBy ((==) `on` fst)
-  . sortBy (compare `on` fst)
+    List.nubBy ((==) `on` fst)
+  . List.sortBy (compare `on` fst)
 
 -- | Shrink a key\/operation sequence (without regard to key order).
 shrinkKeyOps :: [(Key, Operation)] -> [[(Key, Operation)]]
diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs
@@ -63,7 +63,7 @@ import qualified Control.Concurrent.Class.MonadSTM.RWVar as RW
 import           Control.DeepSeq
 import           Control.Monad (unless, void, when)
 import           Control.Monad.Class.MonadThrow
-import           Control.Monad.Primitive (PrimState (..), RealWorld)
+import           Control.Monad.Primitive (PrimState, RealWorld)
 import           Control.Monad.ST.Strict (ST, runST)
 import           Data.Arena (ArenaManager, newArenaManager)
 import           Data.Bifunctor (Bifunctor (..))
diff --git a/src/Database/LSMTree/Internal/Lookup.hs b/src/Database/LSMTree/Internal/Lookup.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE DerivingStrategies  #-}
@@ -230,7 +231,7 @@ data ByteCountDiscrepancy = ByteCountDiscrepancy {
 -- PRECONDITION: the vectors of bloom filters, indexes and file handles
 -- should pointwise match with the vectors of runs.
 lookupsIO ::
-     forall m h. (PrimMonad m, MonadThrow m, MonadST m)
+     forall m h. (MonadThrow m, MonadST m)
   => HasBlockIO m h
   -> ArenaManager (PrimState m)
   -> ResolveSerialisedValue
diff --git a/src/Database/LSMTree/Internal/RawPage.hs b/src/Database/LSMTree/Internal/RawPage.hs
@@ -44,7 +44,7 @@ import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.Serialise (SerialisedKey (..),
                      SerialisedValue (..))
 import           Database.LSMTree.Internal.Vector
-import           GHC.List (foldl')
+import qualified GHC.List as List
 
 -------------------------------------------------------------------------------
 -- RawPage type
@@ -398,6 +398,6 @@ rawPageCalculateBlobIndex (RawPage off ba) i = do
     let j = unsafeShiftR i 6 -- `div` 64
     let k = i .&. 63         -- `mod` 64
     -- generic sum isn't too great
-    let s = foldl' (+) 0 [ popCount (indexByteArray ba (div4 off + 1 + jj) :: Word64) | jj <- [0 .. j-1 ] ]
+    let s = List.foldl' (+) 0 [ popCount (indexByteArray ba (div4 off + 1 + jj) :: Word64) | jj <- [0 .. j-1 ] ]
     let word = indexByteArray ba (div4 off + 1 + j) :: Word64
     s + popCount (word .&. complement (unsafeShiftL 0xffffffffffffffff k))
diff --git a/test/Database/LSMTree/Model/Monoidal.hs b/test/Database/LSMTree/Model/Monoidal.hs
diff --git a/test/Database/LSMTree/Model/Normal.hs b/test/Database/LSMTree/Model/Normal.hs
diff --git a/test/Database/LSMTree/ModelIO/Monoidal.hs b/test/Database/LSMTree/ModelIO/Monoidal.hs
diff --git a/test/Database/LSMTree/ModelIO/Normal.hs b/test/Database/LSMTree/ModelIO/Normal.hs
diff --git a/test/Test/Database/LSMTree/Internal/CRC32C.hs b/test/Test/Database/LSMTree/Internal/CRC32C.hs
