Merge branch 'main' into wenkokke/export-time

wenkokke · web-flow · commit 1bdcfd02eb2e · 2025-01-30T13:15:06.000Z
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -11,7 +11,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ["8.10", "9.2", "9.4", "9.6", "9.8", "9.10"]
+        ghc: ["8.10", "9.2", "9.4", "9.6", "9.8", "9.10", "9.12"]
         os: [ubuntu-latest, macos-latest, windows-latest]
 
     defaults:
@@ -32,9 +32,9 @@ jobs:
     - name: Install LLVM (macOS)
       if: runner.os == 'macOS' && matrix.ghc == '8.10'
       run: |
-        brew install llvm@13
-        echo "LLVM_CONFIG=$(brew --prefix llvm@13)/bin/llvm-config" >> $GITHUB_ENV
-        echo "$(brew --prefix llvm@13)/bin" >> $GITHUB_PATH
+        brew install llvm@14
+        echo "LLVM_CONFIG=$(brew --prefix llvm@14)/bin/llvm-config" >> $GITHUB_ENV
+        echo "$(brew --prefix llvm@14)/bin" >> $GITHUB_PATH
 
     - name: Verify LLVM installation
       if: runner.os == 'macOS' && matrix.ghc == '8.10'
diff --git a/cabal.project b/cabal.project
@@ -1,4 +1,4 @@
-index-state: hackage.haskell.org 2024-05-17T03:42:00Z
+index-state: hackage.haskell.org 2025-01-14T02:09:49Z
 
 packages: ./io-sim
           ./io-classes
@@ -11,3 +11,14 @@ package io-classes
 
 package strict-stm
   flags: +asserts
+
+if impl (ghc >= 9.12)
+  allow-newer:
+    -- Stuck on `cabal-3.14` issues and recalcitrant maintainers
+    -- https://github.com/haskell/aeson/issues/1124
+    , aeson:ghc-prim
+    , aeson:template-haskell
+
+    -- Fix blocked by aeson
+    -- https://github.com/haskellari/microstache/issues/43
+    , microstache:base
diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md
@@ -2,6 +2,8 @@
 
 ### next version
 
+* Support ghc-9.12
+
 ### Breaking changes
 
 * Added `threadLabel` to `MonadThread`
diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal
@@ -31,8 +31,8 @@ description:
 
 license:             Apache-2.0
 license-files:       LICENSE NOTICE
-copyright:           2019-2024 Input Output Global Inc (IOG)
-author:              Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant
+copyright:           2019-2025 Input Output Global Inc (IOG)
+author:              Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Neil Davies, Thomas Winant
 maintainer:          Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me
 category:            Control
 build-type:          Simple
@@ -112,7 +112,7 @@ library
                        TypeFamilyDependencies
                        TypeOperators
                        UndecidableInstances
-  build-depends:       base  >=4.9 && <4.21,
+  build-depends:       base  >=4.9 && <4.22,
                        array,
                        async >=2.1,
                        bytestring,
@@ -140,7 +140,7 @@ library strict-stm
   reexported-modules:  Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem
   default-language:    Haskell2010
   default-extensions:  ImportQualifiedPost
-  build-depends:       base        >= 4.9 && <4.21,
+  build-depends:       base        >= 4.9 && <4.22,
                        array,
                        stm         >= 2.5 && <2.6,
 
@@ -163,7 +163,7 @@ library strict-mvar
   exposed-modules:     Control.Concurrent.Class.MonadMVar.Strict
   default-language:    Haskell2010
   default-extensions:  ImportQualifiedPost
-  build-depends:       base        >= 4.9 && <4.21,
+  build-depends:       base        >= 4.9 && <4.22,
                        io-classes:io-classes,
   ghc-options:         -Wall
                        -Wno-unticked-promoted-constructors
@@ -190,7 +190,7 @@ library si-timers
                        NumericUnderscores,
                        ScopedTypeVariables,
                        TypeFamilies
-  build-depends:       base              >=4.9 && <4.21,
+  build-depends:       base              >=4.9 && <4.22,
                        deepseq,
                        mtl,
                        nothunks,
@@ -214,7 +214,7 @@ library mtl
                    ,  Control.Monad.Class.MonadTime.SI.Trans
                    ,  Control.Monad.Class.MonadTimer.Trans
                    ,  Control.Monad.Class.MonadTimer.SI.Trans
-    build-depends:    base >=4.9 && <4.21,
+    build-depends:    base >=4.9 && <4.22,
                       array,
                       mtl,
 
@@ -231,7 +231,7 @@ library testlib
   exposed-modules:     Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF
   default-language:    Haskell2010
   default-extensions:  ImportQualifiedPost
-  build-depends:       base              >=4.9 && <4.21,
+  build-depends:       base              >=4.9 && <4.22,
                        nothunks,
                        QuickCheck,
                        io-classes:strict-mvar
diff --git a/io-classes/mtl/Control/Monad/Class/MonadSTM/Trans.hs b/io-classes/mtl/Control/Monad/Class/MonadSTM/Trans.hs
@@ -54,9 +54,7 @@ instance ( MonadSTM m, MArray e a (STM m) ) => MArray e a (ContTSTM r m) where
     getNumElements    = ContTSTM . getNumElements
     unsafeRead arr    = ContTSTM . unsafeRead arr
     unsafeWrite arr i = ContTSTM . unsafeWrite arr i
-#if __GLASGOW_HASKELL__ >= 910
     newArray idxs     = ContTSTM . newArray idxs
-#endif
 
 
 -- note: this (and the following) instance requires 'UndecidableInstances'
diff --git a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs
@@ -1030,7 +1030,6 @@ unGetTBQueueDefault (TBQueue rsize read wsize _write _size) a = do
 -- | Default implementation of 'TArray'.
 --
 data TArrayDefault m i e = TArray (Array i (TVar m e))
-  deriving Typeable
 
 deriving instance (Eq (TVar m e), Ix i) => Eq (TArrayDefault m i e)
 
diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md
@@ -22,6 +22,9 @@
   - `selectTraceEventsSayWithTime'`
   is more general.  These functions now accepts trace with any result, rather
   than one that finishes with `SimResult`.
+- More polymorphic `ppTrace_` type signature.
+- Fixed `tryReadTBQueue` when returning `Nothing`.
+- Support ghc 9.12
 - Export `Time` from `Control.Monad.IOSim`.
 
 ## 1.6.0.0
diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal
@@ -12,7 +12,7 @@ description:
   [here](https://input-output-hk.github.io/io-sim/io-sim).
 license:             Apache-2.0
 license-files:       LICENSE NOTICE
-copyright:           2022-2024 Input Output Global Inc (IOG)
+copyright:           2022-2025 Input Output Global Inc (IOG)
 author:              Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski
 maintainer:          Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me
 category:            Testing
@@ -79,7 +79,7 @@ library
                        RankNTypes,
                        ScopedTypeVariables,
                        TypeFamilies
-  build-depends:       base              >=4.9 && <4.21,
+  build-depends:       base              >=4.9 && <4.22,
                        io-classes:{io-classes,strict-stm,si-timers}
                                         ^>=1.6 || ^>= 1.7,
                        exceptions        >=0.10,
diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs
@@ -149,9 +149,7 @@ tryReadTBQueueDefault (TBQueue queue _size) = do
       return (Just x)
     [] ->
       case reverse ys of
-        [] -> do
-          writeTVar queue $! (xs, r', ys, w)
-          return Nothing
+        [] -> return Nothing
 
         -- NB. lazy: we want the transaction to be
         -- short, otherwise it will conflict
diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs
@@ -938,7 +938,7 @@ ppTrace tr = Trace.ppTrace
 
 -- | Like 'ppTrace' but does not show the result value.
 --
-ppTrace_ :: SimTrace a -> String
+ppTrace_ :: Trace.Trace a SimEvent -> String
 ppTrace_ tr = Trace.ppTrace
                 (const "")
                 (ppSimEvent timeWidth tidWidth labelWidth)
diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs
@@ -192,6 +192,10 @@ tests =
       , testProperty "maintains FIFO order IO" prop_flushTBQueueOrder_IO
       , testProperty "maintains FIFO order IOSim" prop_flushTBQueueOrder_IOSim
       ]
+    , testGroup "tryReadTBQueue"
+      [ testProperty "works correctly when the queue is empty IO" prop_tryReadEmptyTBQueue_IO
+      , testProperty "works correctly when the queue is empty IOSim" prop_tryReadEmptyTBQueue_IOSim
+      ]
     ]
   ]
 
@@ -1464,6 +1468,24 @@ writeAndFlushTBQueue entries =
     forM_ entries $ writeTBQueue q
     flushTBQueue q
 
+prop_tryReadEmptyTBQueue_IO :: Bool -> Property
+prop_tryReadEmptyTBQueue_IO sndRead =
+  ioProperty $ tryReadEmptyTBQueue sndRead
+
+prop_tryReadEmptyTBQueue_IOSim :: Bool -> Property
+prop_tryReadEmptyTBQueue_IOSim sndRead =
+  runSimOrThrow $ tryReadEmptyTBQueue sndRead
+
+tryReadEmptyTBQueue :: MonadSTM m => Bool -> m Property
+tryReadEmptyTBQueue sndRead = atomically $ do
+  q <- newTBQueue 10
+  _ <- tryReadTBQueue q
+  writeTBQueue q ()
+  when sndRead $ void $ tryReadTBQueue q
+  l <- lengthTBQueue q
+
+  pure $ l === if sndRead then 0 else 1
+
 --
 -- Utils
 --
diff --git a/io-sim/test/Test/Control/Monad/IOSimPOR.hs b/io-sim/test/Test/Control/Monad/IOSimPOR.hs
@@ -434,15 +434,31 @@ doit n = do
   threadDelay 1
   readTVarIO r
 
-
-traceNoDuplicates :: (Testable prop1, Show a1) => ((a1 -> a2 -> a2) -> prop1) -> Property
-traceNoDuplicates k = r `pseq` (k addTrace .&&. maximum (traceCounts ()) == 1)
+traceNoDuplicates :: forall a b.
+                     (Show a)
+                  => ((a -> b -> b) -> Property)
+                  -> Property
+-- this NOINLINE pragma is useful for debugging if `r` didn't flow outside of
+-- `traceNoDuplicate`.
+{-# NOINLINE traceNoDuplicates #-}
+traceNoDuplicates k = unsafePerformIO $ do
+    r <- newIORef (Map.empty :: Map String Int)
+    return $ r `pseq`
+             (k (addTrace r) .&&. counterexample "trace counts" (maximum (Map.elems (traceCounts r)) === 1))
   where
-    r = unsafePerformIO $ newIORef (Map.empty :: Map String Int)
-    addTrace t x = unsafePerformIO $ do
-      atomicModifyIORef r (\m->(Map.insertWith (+) (show t) 1 m,()))
+    addTrace :: IORef (Map String Int) -> a -> b -> b
+    addTrace r t x = unsafePerformIO $ do
+      let s = show t
+      atomicModifyIORef r
+        (\m->
+          let m' = Map.insertWith (+) s 1 m
+          in (m', ())
+        )
       return x
-    traceCounts () = unsafePerformIO $ Map.elems <$> readIORef r
+
+    traceCounts :: IORef (Map String Int) -> Map String Int
+    traceCounts r = unsafePerformIO $ readIORef r
+
 
 -- | Checks that IOSimPOR is capable of analysing an infinite simulation
 -- lazily.
