Provide support for uniques

niio.cabal

@@ -24,6 +24,7 @@ common lang
   default-extensions:
       DeriveFunctor
       DerivingStrategies
+      GeneralizedNewtypeDeriving
       StandaloneDeriving
 
 library

src/System/IO/NonInterleaved.hs

@@ -11,14 +11,17 @@ module System.IO.NonInterleaved (
   , niTraceShowId
   , niTraceM
   , niTraceShowM
-    -- * Derived functionality
+    -- * Additional functionality
+  , Unique -- opaque
+  , niGetUnique
   , niBracket
   , niBracketLn
   ) where
 
 import Control.Concurrent
 import Control.Monad.Catch (MonadMask, ExitCase(..), generalBracket)
 import Control.Monad.IO.Class
+import Data.IORef
 import System.IO
 import System.IO.Temp (getCanonicalTemporaryDirectory)
 import System.IO.Unsafe
@@ -81,31 +84,55 @@ niTraceShowM :: (Applicative m, Show a) => a -> m ()
 niTraceShowM = niTraceM . show
 
 {-------------------------------------------------------------------------------
-  Derived functionality
+  Additional functionality
 -------------------------------------------------------------------------------}
 
+-- | Unique value
+--
+-- See 'niGetUnique'.
+newtype Unique = Unique Int
+  deriving newtype (Show, Eq)
+
+-- | Get a unique value
+--
+-- Every call to 'niGetUnique' will return a different (unique) value. This can
+-- be useful to correlate different log messages with each other.
+niGetUnique :: MonadIO m => m Unique
+niGetUnique = liftIO $ atomicModifyIORef niUnique $ \i -> (succ i, Unique i)
+
 -- | Print a message before and after an action
 --
+-- In order to make it easier to correlate the messages before and after the
+-- action, we give both a newly created 'Unique' (see 'niGetUnique').
+--
 -- NOTE: We provide an (orphan) 'Functor' instance for 'ExitCase', which can
 -- be useful in cases where @a@ is not showable.
 niBracket ::
      (MonadIO m, MonadMask m)
-  => String                  -- ^ Message to print prior to the action
-  -> (ExitCase a -> String)  -- ^ Message to print after
-  -> m a -> m a
-niBracket before after act = fmap (\(a, ()) -> a) $
+  => (Unique -> String)                -- ^ Message to print prior to the action
+  -> (Unique -> ExitCase a -> String)  -- ^ Message to print after
+  -> (Unique -> m a)
+  -> m a
+niBracket before after act = fmap (\(a, ()) -> a) $ do
+    i <- niGetUnique
     generalBracket
-      (niPutStr before)
-      (\() -> niPutStr . after)
-      (\() -> act)
+      (niPutStr $ before i)
+      (\() -> niPutStr . after i)
+      (\() -> act i)
 
 -- | Like 'niBracket', but adding linebreaks.
 --
 -- 'niBracketLn' is to 'niBracket' as 'niPutStrLn' is to 'niPutStr'.
 niBracketLn ::
      (MonadIO m, MonadMask m)
-  => String -> (ExitCase a -> String) -> m a -> m a
-niBracketLn before after = niBracket (before ++ "\n") ((++ "\n") . after)
+  => (Unique -> String)
+  -> (Unique -> ExitCase a -> String)
+  -> (Unique -> m a)
+  -> m a
+niBracketLn before after =
+    niBracket
+      (\i -> before i ++ "\n")
+      (\i -> (++ "\n") . after i)
 
 deriving stock instance Functor ExitCase
 
@@ -120,3 +147,7 @@ niHandle = unsafePerformIO $ do
     (fp, h) <- openTempFile tmpDir "niio"
     hPutStrLn stderr $ "niio output to " ++ fp
     newMVar h
+
+niUnique :: IORef Int
+{-# NOINLINE niUnique #-}
+niUnique = unsafePerformIO $ newIORef 1