{-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
module Network.HTTP.Server.Mini.Internal.Instrument where

import Control.Concurrent
import Control.Monad (void)
import Data.IORef
import Data.Text qualified as T
import Data.Text.IO.Utf8 qualified as T
import Data.Text (Text)
import Data.Time.Clock.POSIX
import System.IO
import System.IO.Unsafe (unsafePerformIO)


{-# NOINLINE nextId #-}
nextId :: IORef Int
nextId = unsafePerformIO (newIORef 1)

-- Number of instrument blocks open
{-# NOINLINE numOpen #-}
numOpen :: IORef Int
numOpen = unsafePerformIO (newIORef 0)

{-# NOINLINE mutex #-}
mutex :: MVar ()
mutex = unsafePerformIO (newMVar ())

instrument :: String -> IO a -> IO a
instrument name action = do
  idval <- atomicModifyIORef' nextId (\i -> (i+1, i))
  atomicPrintS (show idval ++ "< " ++ name)
  atomicModifyIORef' numOpen (\i -> (i+1, ()))
  t1 <- getPOSIXTime
  res <- action
  t2 <- getPOSIXTime
  numOpenAfter <- atomicModifyIORef' numOpen (\i -> (i-1, i-1))
  atomicPrintS (show idval ++ "> " ++ name ++ " (" ++ show (t2 - t1) ++ ") (" ++ show numOpenAfter ++ ")")
  return res

atomicPrintS :: String -> IO ()
atomicPrintS = atomicPrint . T.pack

atomicPrint :: Text -> IO ()
atomicPrint text =
  withMVar mutex $ \() ->
    T.putStrLn text >> hFlush stdout

atomicPrintNoWaitS :: String -> IO ()
atomicPrintNoWaitS = atomicPrintNoWait . T.pack

-- | Does not block, so if you've masked exceptions, nothing will come through here
atomicPrintNoWait :: Text -> IO ()
atomicPrintNoWait text = void $ forkIO $ atomicPrint text