Improve async runtime scaling (jaspervdj#946)

Zekt · Aug 23, 2023 · 9696a85 · 9696a85
1 parent ec3365a
commit 9696a85
Show file tree

Hide file tree

Showing 6 changed files with 398 additions and 235 deletions.
diff --git a/hakyll.cabal b/hakyll.cabal
@@ -194,7 +194,6 @@ Library
     file-embed           >= 0.0.10.1 && < 0.0.16,
     filepath             >= 1.0      && < 1.5,
     hashable             >= 1.0      && < 2,
-    lifted-async         >= 0.10     && < 1,
     lrucache             >= 1.1.1    && < 1.3,
     mtl                  >= 1        && < 2.4,
     network-uri          >= 2.6      && < 2.7,

diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs
@@ -1,5 +1,6 @@
 --------------------------------------------------------------------------------
 -- | Produce pretty, thread-safe logs
+{-# LANGUAGE Rank2Types #-}
 module Hakyll.Core.Logger
     ( Verbosity (..)
     , Logger
@@ -9,15 +10,19 @@ module Hakyll.Core.Logger
     , header
     , message
     , debug
+
+    -- * Testing utilities
+    , newInMem
     ) where
 
 
 --------------------------------------------------------------------------------
 import           Control.Concurrent      (forkIO)
-import           Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
-import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
-import           Control.Monad           (forever)
+import           Control.Concurrent.Chan (newChan, readChan, writeChan)
+import           Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import           Control.Monad           (forever, when)
 import           Control.Monad.Trans     (MonadIO, liftIO)
+import qualified Data.IORef              as IORef
 import           Data.List               (intercalate)
 import           Prelude                 hiding (error)
 
@@ -31,51 +36,34 @@ data Verbosity
 
 
 --------------------------------------------------------------------------------
--- | Logger structure. Very complicated.
 data Logger = Logger
-    { loggerChan      :: Chan (Maybe String)  -- ^ Nothing marks the end
-    , loggerSync      :: MVar ()              -- ^ Used for sync on quit
-    , loggerSink      :: String -> IO ()      -- ^ Out sink
-    , loggerVerbosity :: Verbosity            -- ^ Verbosity
+    { -- | Flush the logger (blocks until flushed)
+      flush  :: forall m. MonadIO m => m ()
+    , string :: forall m. MonadIO m => Verbosity -> String -> m ()
     }
 
 
 --------------------------------------------------------------------------------
 -- | Create a new logger
 new :: Verbosity -> IO Logger
 new vbty = do
-    logger <- Logger <$>
-        newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty
-    _      <- forkIO $ loggerThread logger
-    return logger
-  where
-    loggerThread logger = forever $ do
-        msg <- readChan $ loggerChan logger
+    chan <- newChan
+    sync <- newEmptyMVar
+    _    <- forkIO $ forever $ do
+        msg <- readChan chan
         case msg of
             -- Stop: sync
-            Nothing -> putMVar (loggerSync logger) ()
+            Nothing -> putMVar sync ()
             -- Print and continue
-            Just m  -> loggerSink logger m
-
-
---------------------------------------------------------------------------------
--- | Flush the logger (blocks until flushed)
-flush :: Logger -> IO ()
-flush logger = do
-    writeChan (loggerChan logger) Nothing
-    () <- takeMVar $ loggerSync logger
-    return ()
-
-
---------------------------------------------------------------------------------
-string :: MonadIO m
-       => Logger     -- ^ Logger
-       -> Verbosity  -- ^ Verbosity of the string
-       -> String     -- ^ Section name
-       -> m ()       -- ^ No result
-string l v m
-    | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)
-    | otherwise              = return ()
+            Just m  -> putStrLn m
+    return $ Logger
+        { flush = liftIO $ do
+            writeChan chan Nothing
+            () <- takeMVar sync
+            return ()
+        , string = \v m -> when (vbty >= v) $
+            liftIO $ writeChan chan (Just m)
+        }
 
 
 --------------------------------------------------------------------------------
@@ -101,3 +89,19 @@ debug l m = string l Debug $ "  [DEBUG] " ++ indent m
 --------------------------------------------------------------------------------
 indent :: String -> String
 indent = intercalate "\n    " . lines
+
+
+--------------------------------------------------------------------------------
+-- | Create a new logger that just stores all the messages, useful for writing
+-- tests.
+newInMem :: IO (Logger, IO [(Verbosity, String)])
+newInMem = do
+    ref <- IORef.newIORef []
+    pure
+        ( Logger
+            { string = \vbty msg -> liftIO $ IORef.atomicModifyIORef' ref $
+                \msgs -> ((vbty, msg) : msgs, ())
+            , flush  = pure ()
+            }
+        , reverse <$> IORef.readIORef ref
+        )