diff --git a/app/Main.hs b/app/Main.hs index 514a38ff6..ae3621d66 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/Ormolu.hs b/src/Ormolu.hs index a8da9fb2c..4d2562ff5 100644 --- a/src/Ormolu.hs +++ b/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 diff --git a/src/Ormolu/Logging.hs b/src/Ormolu/Logging.hs index 8ec080ada..ab9d84de7 100644 --- a/src/Ormolu/Logging.hs +++ b/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