    {-# 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))