Allow logging anywhere

app/Main.hs

@@ -40,6 +40,7 @@ import System.IO (stderr)
 main :: IO ()
 main = do
   Opts {..} <- execParser optsParserInfo
+  initializeLogging optConfig
   let formatOne' =
         formatOne
           optConfigFileOpts
@@ -85,11 +86,11 @@ formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath =
           cabalSearchResult <- getCabalInfoForSourceFile sourceFile
           case cabalSearchResult of
             CabalNotFound -> do
-              logDebug rawConfig "CABAL FILE" $ "Could not find a .cabal file for " <> sourceFile
+              logDebugM "CABAL FILE" $ "Could not find a .cabal file for " <> sourceFile
               return Nothing
             CabalDidNotMention cabalInfo -> do
               relativeCabalFile <- makeRelativeToCurrentDirectory (ciCabalFilePath cabalInfo)
-              logDebug rawConfig "CABAL FILE" $
+              logDebugM "CABAL FILE" $
                 "Found .cabal file "
                   <> relativeCabalFile
                   <> ", but it did not mention "
@@ -116,7 +117,7 @@ formatOne ConfigFileOpts {..} mode reqSourceType rawConfig mpath =
             ormoluStdin config >>= TIO.putStr
             return ExitSuccess
           InPlace -> do
-            logError "In place editing is not supported when input comes from stdin."
+            logErrorM "In place editing is not supported when input comes from stdin."
             -- 101 is different from all the other exit codes we already use.
             return (ExitFailure 101)
           Check -> do

src/Ormolu.hs

@@ -93,19 +93,19 @@ ormolu cfgWithIndices path originalInput = do
           (overapproximatedDependencies cfg) -- memoized on the set of dependencies
 
   -- log inputs in debug logs
-  logDebug cfg "CONFIG" $ show cfg
+  logDebugM "CONFIG" $ show cfg
 
   (warnings, result0) <-
     parseModule' cfg fixityMap OrmoluParsingFailed path originalInput
 
   -- log parsing results in debug logs
   forM_ warnings $ \(GHC.Warn reason (L loc msg)) ->
-    logDebug cfg "WARNING" $ unwords [showOutputable loc, msg, showOutputable reason]
+    logDebugM "WARNING" $ unwords [showOutputable loc, msg, showOutputable reason]
   forM_ result0 $ \case
     ParsedSnippet r -> do
       let CommentStream comments = prCommentStream r
       forM_ comments $ \(L loc comment) ->
-        logDebug cfg "COMMENT" $ unwords [showOutputable loc, show comment]
+        logDebugM "COMMENT" $ unwords [showOutputable loc, show comment]
     _ -> pure ()
 
   -- We're forcing 'formattedText' here because otherwise errors (such as

src/Ormolu/Logging.hs

@@ -1,31 +1,76 @@
 module Ormolu.Logging
-  ( logDebug,
+  ( initializeLogging,
+    logDebug,
+    logDebugM,
     logError,
+    logErrorM,
   )
 where
 
-import Control.Monad (when)
-import Control.Monad.IO.Class (MonadIO (..))
+import Data.Foldable (traverse_)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Ormolu.Config (Config (..))
 import System.IO (hPutStrLn, stderr)
+import System.IO.Unsafe (unsafePerformIO)
 
+data LoggerConfig = LoggerConfig
+  { debugEnabled :: Bool
+  }
+
+loggerConfig :: IORef LoggerConfig
+loggerConfig = unsafePerformIO $ newIORef (error "Logger not configured yet")
+{-# NOINLINE loggerConfig #-}
+
+initializeLogging :: Config region -> IO ()
+initializeLogging cfg =
+  writeIORef loggerConfig $
+    LoggerConfig
+      { debugEnabled = cfgDebug cfg
+      }
+
+-- | Output a debug log to stderr.
+--
+-- Requires initializeLogging to be called first.
 logDebug ::
-  (MonadIO m) =>
-  Config region ->
+  -- | Some label to prefix the message with
+  String ->
+  -- | The message, ideally on a single line
+  String ->
+  a ->
+  a
+logDebug label msg = logToStderr getMessage
+  where
+    getMessage = do
+      cfg <- readIORef loggerConfig
+      pure $
+        if debugEnabled cfg
+          then
+            Just . unwords $
+              [ "*** " <> label <> " ***",
+                msg
+              ]
+          else Nothing
+
+-- | Output a debug log to stderr.
+--
+-- Requires initializeLogging to be called first.
+logDebugM ::
+  (Monad m) =>
   -- | Some label to prefix the message with
   String ->
   -- | The message, ideally on a single line
   String ->
   m ()
-logDebug Config {cfgDebug} label msg =
-  when cfgDebug $
-    logToStderr . unwords $
-      [ "*** " <> label <> " ***",
-        msg
-      ]
-
-logError :: (MonadIO m) => String -> m ()
-logError = logToStderr
-
-logToStderr :: (MonadIO m) => String -> m ()
-logToStderr = liftIO . hPutStrLn stderr
+logDebugM label msg = logDebug label msg $ pure ()
+
+logError :: String -> a -> a
+logError = logToStderr . pure . Just
+
+logErrorM :: (Monad m) => String -> m ()
+logErrorM msg = logError msg $ pure ()
+
+logToStderr :: IO (Maybe String) -> a -> a
+logToStderr getMessage a =
+  unsafePerformIO $ do
+    traverse_ (hPutStrLn stderr) =<< getMessage
+    pure a