-- | Functions for non-interleaved output
--
-- Intended for qualifed import.
--
-- > import Debug.NonInterleavedIO qualified as NIIO
--
-- Alternatively, you can import "Debug.NonInterleavedIO.Trace" as a drop-in
-- replacement for "Debug.Trace".
--
-- The functions in this module can all be called concurrently, without
-- resulting in interleaved output: each function call is atomic.
--
-- The first time any of these functions is called, we lookup the @NIIO_OUTPUT@
-- environment variable. If set, we will write to the file specified (if the
-- file already exists, it will be overwritten). If @NIIO_OUTPUT@ is not set, a
-- temporary file will be created in the system temporary directory; typically
-- such a file will be called @/tmp/niio<number>@. The name of this file is
-- written to @stderr@ (this is the /only/ output origiating from functions in
-- this module that is not written to the file).
module Debug.NonInterleavedIO (
    -- * Output functions
    putStr
  , putStrLn
  , print
    -- * Tracing functions
  , trace
  , traceShow
  , traceShowId
  , traceM
  , traceShowM
  ) where

import Prelude hiding (putStr, putStrLn, print)

import Control.Concurrent
import Control.Exception
import Control.Monad.IO.Class
import System.Environment
import System.IO qualified as IO
import System.IO.Temp (getCanonicalTemporaryDirectory)
import System.IO.Unsafe

{-------------------------------------------------------------------------------
  Output functions
-------------------------------------------------------------------------------}

-- | Non-interleaved version of 'Prelude.putStr'
putStr :: MonadIO m => String -> m ()
putStr :: forall (m :: * -> *). MonadIO m => String -> m ()
putStr String
str = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar Handle -> (Handle -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
globalHandle ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    Handle -> String -> IO ()
IO.hPutStr Handle
h String
str
    Handle -> IO ()
IO.hFlush Handle
h

-- | Non-interleaved version of 'Prelude.putStrLn'
putStrLn :: MonadIO m => String -> m ()
putStrLn :: forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStr (String -> m ()) -> (String -> String) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")

-- | Non-interleaved version of 'Prelude.print'
print :: MonadIO m => Show a => a -> m ()
print :: forall (m :: * -> *) a. (MonadIO m, Show a) => a -> m ()
print = String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

{-------------------------------------------------------------------------------
  Tracing
-------------------------------------------------------------------------------}

-- | Non-interleaved version of 'Debug.Trace.trace'
trace :: String -> a -> a
trace :: forall a. String -> a -> a
trace String
str a
a = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn String
str IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Non-interleaved version of 'Debug.Trace.traceShow'
traceShow :: Show a  => a -> b -> b
traceShow :: forall a b. Show a => a -> b -> b
traceShow = String -> b -> b
forall a. String -> a -> a
trace (String -> b -> b) -> (a -> String) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Non-interleaved version of 'Debug.Trace.traceShowId'
traceShowId :: Show a => a -> a
traceShowId :: forall a. Show a => a -> a
traceShowId a
a = String -> a -> a
forall a b. Show a => a -> b -> b
traceShow (a -> String
forall a. Show a => a -> String
show a
a) a
a

-- | Non-interleaved version of 'Debug.Trace.traceM'
traceM :: Applicative m => String -> m ()
traceM :: forall (m :: * -> *). Applicative m => String -> m ()
traceM String
str = String -> m () -> m ()
forall a. String -> a -> a
trace String
str (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Non-interleaved version of 'Debug.Trace.traceShowM'
traceShowM :: (Applicative m, Show a) => a -> m ()
traceShowM :: forall (m :: * -> *) a. (Applicative m, Show a) => a -> m ()
traceShowM = String -> m ()
forall (m :: * -> *). Applicative m => String -> m ()
traceM (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

{-------------------------------------------------------------------------------
  Internal: globals
-------------------------------------------------------------------------------}

globalHandle :: MVar IO.Handle
{-# NOINLINE globalHandle #-}
globalHandle :: MVar Handle
globalHandle = IO (MVar Handle) -> MVar Handle
forall a. IO a -> a
unsafePerformIO (IO (MVar Handle) -> MVar Handle)
-> IO (MVar Handle) -> MVar Handle
forall a b. (a -> b) -> a -> b
$ IO (MVar Handle) -> IO (MVar Handle)
forall a. IO a -> IO a
uninterruptibleMask_ (IO (MVar Handle) -> IO (MVar Handle))
-> IO (MVar Handle) -> IO (MVar Handle)
forall a b. (a -> b) -> a -> b
$ do
    mOutput <- String -> IO (Maybe String)
lookupEnv String
"NIIO_OUTPUT"
    (fp, h) <- case mOutput of
                 Maybe String
Nothing -> do
                   tmpDir <- IO String
getCanonicalTemporaryDirectory
                   IO.openTempFile tmpDir "niio"
                 Just String
fp -> do
                   (String
fp,) (Handle -> (String, Handle)) -> IO Handle -> IO (String, Handle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IOMode -> IO Handle
IO.openFile String
fp IOMode
IO.WriteMode
    IO.hPutStrLn IO.stderr $ "niio output to " ++ fp
    IO.hFlush IO.stderr
    newMVar h