Merge pull request #202 from input-output-hk/coot/ppTrace_

io-sim: more general ppTrace_ type signature
input-output-hk · Jan 8, 2025 · 10c1bec · 10c1bec
2 parents 573aa8d + c035dea
commit 10c1bec
Show file tree

Hide file tree

Showing 5 changed files with 28 additions and 13 deletions.
diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml
@@ -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/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-sim/CHANGELOG.md b/io-sim/CHANGELOG.md
@@ -22,6 +22,7 @@
   - `selectTraceEventsSayWithTime'`
   is more general.  These functions now accepts trace with any result, rather
   than one that finishes with `SimResult`.
+- More polymorphic `ppTrace_` type signature.
 
 ## 1.6.0.0
 

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/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.