semigroup and monoid instances for DebugSelector
mempty is NoDebugSelector, so it does not default to matching everything, or nothing, in a chain like foo <> mempty
This commit is contained in:
parent
b4de4b2589
commit
6136006106
2 changed files with 28 additions and 12 deletions
|
@ -251,7 +251,7 @@ showRaw s = outputMessage JSON.none (s <> "\n")
|
||||||
setupConsole :: IO ()
|
setupConsole :: IO ()
|
||||||
setupConsole = do
|
setupConsole = do
|
||||||
dd <- debugDisplayer
|
dd <- debugDisplayer
|
||||||
configureDebug dd (DebugSelector (\_ -> False))
|
configureDebug dd mempty
|
||||||
{- Force output to be line buffered. This is normally the case when
|
{- Force output to be line buffered. This is normally the case when
|
||||||
- it's connected to a terminal, but may not be when redirected to
|
- it's connected to a terminal, but may not be when redirected to
|
||||||
- a file or a pipe. -}
|
- a file or a pipe. -}
|
||||||
|
@ -270,7 +270,7 @@ enableDebugOutput = do
|
||||||
disableDebugOutput :: Annex ()
|
disableDebugOutput :: Annex ()
|
||||||
disableDebugOutput = liftIO $ do
|
disableDebugOutput = liftIO $ do
|
||||||
dd <- debugDisplayer
|
dd <- debugDisplayer
|
||||||
configureDebug dd (DebugSelector (\_ -> False))
|
configureDebug dd mempty
|
||||||
|
|
||||||
debugDisplayer :: IO (S.ByteString -> IO ())
|
debugDisplayer :: IO (S.ByteString -> IO ())
|
||||||
debugDisplayer = do
|
debugDisplayer = do
|
||||||
|
|
|
@ -6,6 +6,7 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}
|
{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-tabs -w #-}
|
{-# OPTIONS_GHC -fno-warn-tabs -w #-}
|
||||||
|
|
||||||
module Utility.Debug (
|
module Utility.Debug (
|
||||||
|
@ -22,6 +23,8 @@ import Data.IORef
|
||||||
import Data.String
|
import Data.String
|
||||||
import Data.Time
|
import Data.Time
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
import qualified Data.Semigroup as Sem
|
||||||
|
import Prelude
|
||||||
|
|
||||||
import Utility.FileSystemEncoding
|
import Utility.FileSystemEncoding
|
||||||
|
|
||||||
|
@ -34,7 +37,18 @@ instance IsString DebugSource where
|
||||||
fromString = DebugSource . encodeBS'
|
fromString = DebugSource . encodeBS'
|
||||||
|
|
||||||
-- | Selects whether to display a message from a source.
|
-- | Selects whether to display a message from a source.
|
||||||
newtype DebugSelector = DebugSelector (DebugSource -> Bool)
|
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.
|
-- | Configures debugging.
|
||||||
configureDebug
|
configureDebug
|
||||||
|
@ -54,7 +68,7 @@ debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector)
|
||||||
debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone)
|
debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone)
|
||||||
where
|
where
|
||||||
dontshow _ = return ()
|
dontshow _ = return ()
|
||||||
selectnone = DebugSelector (\_ -> False)
|
selectnone = NoDebugSelector
|
||||||
|
|
||||||
-- | Displays a debug message, if that has been enabled by configureDebug.
|
-- | Displays a debug message, if that has been enabled by configureDebug.
|
||||||
--
|
--
|
||||||
|
@ -62,21 +76,23 @@ debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone)
|
||||||
-- have to consult a IORef each time, using it in a tight loop may slow
|
-- have to consult a IORef each time, using it in a tight loop may slow
|
||||||
-- down the program.
|
-- down the program.
|
||||||
debug :: DebugSource -> String -> IO ()
|
debug :: DebugSource -> String -> IO ()
|
||||||
debug src msg = do
|
debug src msg = readIORef debugConfigGlobal >>= \case
|
||||||
(displayer, DebugSelector p) <- readIORef debugConfigGlobal
|
(displayer, NoDebugSelector) ->
|
||||||
if p src
|
displayer =<< formatDebugMessage src msg
|
||||||
then displayer =<< formatDebugMessage src msg
|
(displayer, DebugSelector p)
|
||||||
else return ()
|
| p src -> displayer =<< formatDebugMessage src msg
|
||||||
|
| otherwise -> return ()
|
||||||
|
|
||||||
-- | Displays a debug message, if the DebugSelector allows.
|
-- | Displays a debug message, if the DebugSelector allows.
|
||||||
--
|
--
|
||||||
-- When the DebugSelector does not let the message be displayed, this runs
|
-- When the DebugSelector does not let the message be displayed, this runs
|
||||||
-- very quickly, allowing it to be used inside tight loops.
|
-- very quickly, allowing it to be used inside tight loops.
|
||||||
fastDebug :: DebugSelector -> DebugSource -> String -> IO ()
|
fastDebug :: DebugSelector -> DebugSource -> String -> IO ()
|
||||||
|
fastDebug NoDebugSelector src msg = do
|
||||||
|
(displayer, _) <- readIORef debugConfigGlobal
|
||||||
|
displayer =<< formatDebugMessage src msg
|
||||||
fastDebug (DebugSelector p) src msg
|
fastDebug (DebugSelector p) src msg
|
||||||
| p src = do
|
| p src = fastDebug NoDebugSelector src msg
|
||||||
(displayer, _) <- readIORef debugConfigGlobal
|
|
||||||
displayer =<< formatDebugMessage src msg
|
|
||||||
| otherwise = return ()
|
| otherwise = return ()
|
||||||
|
|
||||||
formatDebugMessage :: DebugSource -> String -> IO S.ByteString
|
formatDebugMessage :: DebugSource -> String -> IO S.ByteString
|
||||||
|
|
Loading…
Reference in a new issue