diff options
author | Sean Whitton <spwhitton@spwhitton.name> | 2024-03-19 19:47:48 +0800 |
---|---|---|
committer | Sean Whitton <spwhitton@spwhitton.name> | 2024-03-19 19:47:48 +0800 |
commit | 4b47032686c52de5bf2324c1b1d4151c5fd6c41b (patch) | |
tree | 85098e25c0a4ad383f267fd59d591346d5e09a17 /Utility/Debug.hs | |
parent | 34f99f9355c275917ff91539bbdac60a56ad7e17 (diff) | |
parent | 4993eab4a4507d52037ff74c67f6ca04d2401b5e (diff) | |
download | git-repair-4b47032686c52de5bf2324c1b1d4151c5fd6c41b.tar.gz |
Merge tag '1.20230814'
tagging package git-repair version 1.20230814
Diffstat (limited to 'Utility/Debug.hs')
-rw-r--r-- | Utility/Debug.hs | 102 |
1 files changed, 102 insertions, 0 deletions
diff --git a/Utility/Debug.hs b/Utility/Debug.hs new file mode 100644 index 0000000..6e6e701 --- /dev/null +++ b/Utility/Debug.hs @@ -0,0 +1,102 @@ +{- Debug output + - + - Copyright 2021 Joey Hess <id@joeyh.name> + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.Debug ( + DebugSource(..), + DebugSelector(..), + configureDebug, + getDebugSelector, + debug, + fastDebug +) where + +import qualified Data.ByteString as S +import Data.IORef +import Data.String +import Data.Time +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Semigroup as Sem +import Prelude + +import Utility.FileSystemEncoding + +-- | The source of a debug message. For example, this could be a module or +-- function name. +newtype DebugSource = DebugSource S.ByteString + deriving (Eq, Show) + +instance IsString DebugSource where + fromString = DebugSource . encodeBS + +-- | Selects whether to display a message from a source. +data DebugSelector + = DebugSelector (DebugSource -> Bool) + | NoDebugSelector + +instance Sem.Semigroup DebugSelector where + DebugSelector a <> DebugSelector b = DebugSelector (\v -> a v || b v) + NoDebugSelector <> NoDebugSelector = NoDebugSelector + NoDebugSelector <> b = b + a <> NoDebugSelector = a + +instance Monoid DebugSelector where + mempty = NoDebugSelector + +-- | Configures debugging. +configureDebug + :: (S.ByteString -> IO ()) + -- ^ Used to display debug output. + -> DebugSelector + -> IO () +configureDebug src p = writeIORef debugConfigGlobal (src, p) + +-- | Gets the currently configured DebugSelector. +getDebugSelector :: IO DebugSelector +getDebugSelector = snd <$> readIORef debugConfigGlobal + +-- A global variable for the debug configuration. +{-# NOINLINE debugConfigGlobal #-} +debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector) +debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone) + where + dontshow _ = return () + selectnone = NoDebugSelector + +-- | Displays a debug message, if that has been enabled by configureDebug. +-- +-- This is reasonably fast when debugging is not enabled, but since it does +-- have to consult a IORef each time, using it in a tight loop may slow +-- down the program. +debug :: DebugSource -> String -> IO () +debug src msg = readIORef debugConfigGlobal >>= \case + (displayer, NoDebugSelector) -> + displayer =<< formatDebugMessage src msg + (displayer, DebugSelector p) + | p src -> displayer =<< formatDebugMessage src msg + | otherwise -> return () + +-- | Displays a debug message, if the DebugSelector allows. +-- +-- When the DebugSelector does not let the message be displayed, this runs +-- very quickly, allowing it to be used inside tight loops. +fastDebug :: DebugSelector -> DebugSource -> String -> IO () +fastDebug NoDebugSelector src msg = do + (displayer, _) <- readIORef debugConfigGlobal + displayer =<< formatDebugMessage src msg +fastDebug (DebugSelector p) src msg + | p src = fastDebug NoDebugSelector src msg + | otherwise = return () + +formatDebugMessage :: DebugSource -> String -> IO S.ByteString +formatDebugMessage (DebugSource src) msg = do + t <- encodeBS . formatTime defaultTimeLocale "[%F %X%Q]" + <$> getZonedTime + return (t <> " (" <> src <> ") " <> encodeBS msg) |