{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DerivingVia #-}
module GHC.Driver.Pipeline.LogQueue ( LogQueue(..)
                                  , newLogQueue
                                  , finishLogQueue
                                  , writeLogQueue
                                  , parLogAction

                                  , LogQueueQueue(..)
                                  , initLogQueue
                                  , allLogQueues
                                  , newLogQueueQueue

                                  , logThread
                                  ) where

import GHC.Prelude
import Control.Concurrent
import Data.IORef
import GHC.Types.Error
import GHC.Types.SrcLoc
import GHC.Utils.Logger
import qualified Data.IntMap as IM
import Control.Concurrent.STM
import Control.Monad

-- LogQueue Abstraction

-- | Each module is given a unique 'LogQueue' to redirect compilation messages
-- to. A 'Nothing' value contains the result of compilation, and denotes the
-- end of the message queue.
data LogQueue = LogQueue { LogQueue -> Key
logQueueId :: !Int
                         , LogQueue -> IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
                         , LogQueue -> MVar ()
logQueueSemaphore :: !(MVar ())
                         }

newLogQueue :: Int -> IO LogQueue
newLogQueue :: Key -> IO LogQueue
newLogQueue Key
n = do
  mqueue <- [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
-> IO (IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
forall a. a -> IO (IORef a)
newIORef []
  sem <- newMVar ()
  return (LogQueue n mqueue sem)

finishLogQueue :: LogQueue -> IO ()
finishLogQueue :: LogQueue -> IO ()
finishLogQueue LogQueue
lq = do
  LogQueue -> Maybe (MessageClass, SrcSpan, SDoc, LogFlags) -> IO ()
writeLogQueueInternal LogQueue
lq Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
forall a. Maybe a
Nothing


writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
writeLogQueue :: LogQueue -> (MessageClass, SrcSpan, SDoc, LogFlags) -> IO ()
writeLogQueue LogQueue
lq (MessageClass, SrcSpan, SDoc, LogFlags)
msg = do
  LogQueue -> Maybe (MessageClass, SrcSpan, SDoc, LogFlags) -> IO ()
writeLogQueueInternal LogQueue
lq ((MessageClass, SrcSpan, SDoc, LogFlags)
-> Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
forall a. a -> Maybe a
Just (MessageClass, SrcSpan, SDoc, LogFlags)
msg)

-- | Internal helper for writing log messages
writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
writeLogQueueInternal :: LogQueue -> Maybe (MessageClass, SrcSpan, SDoc, LogFlags) -> IO ()
writeLogQueueInternal (LogQueue Key
_n IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
ref MVar ()
sem) Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
msg = do
    IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
-> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
    -> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)], ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
ref (([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
  -> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)], ()))
 -> IO ())
-> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
    -> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)], ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \[Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
msgs -> (Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
msgMaybe (MessageClass, SrcSpan, SDoc, LogFlags)
-> [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
-> [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
forall a. a -> [a] -> [a]
:[Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
msgs,())
    _ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
sem ()
    return ()

-- The log_action callback that is used to synchronize messages from a
-- worker thread.
parLogAction :: LogQueue -> LogAction
parLogAction :: LogQueue -> LogAction
parLogAction LogQueue
log_queue LogFlags
log_flags !MessageClass
msgClass !SrcSpan
srcSpan !SDoc
msg =
    LogQueue -> (MessageClass, SrcSpan, SDoc, LogFlags) -> IO ()
writeLogQueue LogQueue
log_queue (MessageClass
msgClass,SrcSpan
srcSpan,SDoc
msg, LogFlags
log_flags)

-- Print each message from the log_queue using the global logger
printLogs :: Logger -> LogQueue -> IO ()
printLogs :: Logger -> LogQueue -> IO ()
printLogs !Logger
logger (LogQueue Key
_n IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
ref MVar ()
sem) = IO ()
read_msgs
  where read_msgs :: IO ()
read_msgs = do
            MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
sem
            msgs <- IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
-> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
    -> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)],
        [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]))
-> IO [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
ref (([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
  -> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)],
      [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]))
 -> IO [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
-> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
    -> ([Maybe (MessageClass, SrcSpan, SDoc, LogFlags)],
        [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]))
-> IO [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
forall a b. (a -> b) -> a -> b
$ \[Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
xs -> ([], [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
-> [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
forall a. [a] -> [a]
reverse [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
xs)
            print_loop msgs

        print_loop :: [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)] -> IO ()
print_loop [] = IO ()
read_msgs
        print_loop (Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
x:[Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
xs) = case Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
x of
            Just (MessageClass
msgClass,SrcSpan
srcSpan,SDoc
msg,LogFlags
flags) -> do
                Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg (Logger -> LogFlags -> Logger
setLogFlags Logger
logger LogFlags
flags) MessageClass
msgClass SrcSpan
srcSpan SDoc
msg
                [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)] -> IO ()
print_loop [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)]
xs
            -- Exit the loop once we encounter the end marker.
            Maybe (MessageClass, SrcSpan, SDoc, LogFlags)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- The LogQueueQueue abstraction

data LogQueueQueue = LogQueueQueue Int (IM.IntMap LogQueue)

newLogQueueQueue :: LogQueueQueue
newLogQueueQueue :: LogQueueQueue
newLogQueueQueue = Key -> IntMap LogQueue -> LogQueueQueue
LogQueueQueue Key
1 IntMap LogQueue
forall a. IntMap a
IM.empty

addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue
addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue
addToQueueQueue LogQueue
lq (LogQueueQueue Key
n IntMap LogQueue
im) = Key -> IntMap LogQueue -> LogQueueQueue
LogQueueQueue Key
n (Key -> LogQueue -> IntMap LogQueue -> IntMap LogQueue
forall a. Key -> a -> IntMap a -> IntMap a
IM.insert (LogQueue -> Key
logQueueId LogQueue
lq) LogQueue
lq IntMap LogQueue
im)

initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM ()
initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM ()
initLogQueue TVar LogQueueQueue
lqq LogQueue
lq = TVar LogQueueQueue -> (LogQueueQueue -> LogQueueQueue) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar LogQueueQueue
lqq (LogQueue -> LogQueueQueue -> LogQueueQueue
addToQueueQueue LogQueue
lq)

-- | Return all items in the queue in ascending order
allLogQueues :: LogQueueQueue -> [LogQueue]
allLogQueues :: LogQueueQueue -> [LogQueue]
allLogQueues (LogQueueQueue Key
_n IntMap LogQueue
im) = IntMap LogQueue -> [LogQueue]
forall a. IntMap a -> [a]
IM.elems IntMap LogQueue
im

dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue)
dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue)
dequeueLogQueueQueue (LogQueueQueue Key
n IntMap LogQueue
lqq) = case IntMap LogQueue -> Maybe ((Key, LogQueue), IntMap LogQueue)
forall a. IntMap a -> Maybe ((Key, a), IntMap a)
IM.minViewWithKey IntMap LogQueue
lqq of
                                                Just ((Key
k, LogQueue
v), IntMap LogQueue
lqq') | Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
n -> (LogQueue, LogQueueQueue) -> Maybe (LogQueue, LogQueueQueue)
forall a. a -> Maybe a
Just (LogQueue
v, Key -> IntMap LogQueue -> LogQueueQueue
LogQueueQueue (Key
n Key -> Key -> Key
forall a. Num a => a -> a -> a
+ Key
1) IntMap LogQueue
lqq')
                                                Maybe ((Key, LogQueue), IntMap LogQueue)
_ -> Maybe (LogQueue, LogQueueQueue)
forall a. Maybe a
Nothing

logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit
                    -> TVar LogQueueQueue -- Queue for logs
                    -> IO (IO ())
logThread :: Logger -> TVar Bool -> TVar LogQueueQueue -> IO (IO ())
logThread Logger
logger TVar Bool
stopped TVar LogQueueQueue
lqq_var = do
  finished_var <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  _ <- forkIO $ print_logs *> putMVar finished_var ()
  return (takeMVar finished_var)
  where
    finish :: [LogQueue] -> IO [()]
finish = (LogQueue -> IO ()) -> [LogQueue] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Logger -> LogQueue -> IO ()
printLogs Logger
logger)

    print_logs :: IO [()]
print_logs = IO (IO [()]) -> IO [()]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO [()]) -> IO [()]) -> IO (IO [()]) -> IO [()]
forall a b. (a -> b) -> a -> b
$ STM (IO [()]) -> IO (IO [()])
forall a. STM a -> IO a
atomically (STM (IO [()]) -> IO (IO [()])) -> STM (IO [()]) -> IO (IO [()])
forall a b. (a -> b) -> a -> b
$ do
      lqq <- TVar LogQueueQueue -> STM LogQueueQueue
forall a. TVar a -> STM a
readTVar TVar LogQueueQueue
lqq_var
      case dequeueLogQueueQueue lqq of
        Just (LogQueue
lq, LogQueueQueue
lqq') -> do
          TVar LogQueueQueue -> LogQueueQueue -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar LogQueueQueue
lqq_var LogQueueQueue
lqq'
          IO [()] -> STM (IO [()])
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> LogQueue -> IO ()
printLogs Logger
logger LogQueue
lq IO () -> IO [()] -> IO [()]
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO [()]
print_logs)
        Maybe (LogQueue, LogQueueQueue)
Nothing -> do
          -- No log to print, check if we are finished.
          stopped <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
stopped
          if not stopped then retry
                         else return (finish (allLogQueues lqq))