From d16d739ce28bdb6597552c32e42a1ac972559a95 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 6 Apr 2021 15:14:00 -0400 Subject: [PATCH] implement fastDebug Most of the changes here involve global option parsing: GlobalSetter changed so it can both run an Annex action to set state, but can also change the AnnexRead value, which is immutable once the Annex monad is running. That allowed a debugselector value to be added to AnnexRead, seeded from the git config. The --debugfilter option's GlobalSetter then updates the AnnexRead. This improved GlobalSetter can later be used to move more stuff to AnnexRead. Things that don't involve a git config will be easier to move, and probably a *lot* of things can be moved eventually. fastDebug, while implemented, is not used anywhere yet. But it should be fast.. --- Annex.hs | 9 ++-- Annex/Debug.hs | 30 +++++++++++++ Annex/Debug/Utility.hs | 32 ++++++++++++++ CmdLine.hs | 13 +++--- CmdLine/GitAnnex/Options.hs | 87 +++++++++++++++++++------------------ CmdLine/GitAnnexShell.hs | 2 +- CmdLine/GlobalSetter.hs | 27 ++++++++---- CmdLine/Option.hs | 36 ++++++++++----- Messages.hs | 13 +++--- Types/DeferredParse.hs | 22 ++++++++-- Types/GitConfig.hs | 5 +-- git-annex.cabal | 2 + 12 files changed, 194 insertions(+), 84 deletions(-) create mode 100644 Annex/Debug.hs create mode 100644 Annex/Debug/Utility.hs diff --git a/Annex.hs b/Annex.hs index e48011bba9..a5a82644be 100644 --- a/Annex.hs +++ b/Annex.hs @@ -76,6 +76,7 @@ import Types.RemoteConfig import Types.TransferrerPool import Types.VectorClock import Annex.VectorClock.Utility +import Annex.Debug.Utility import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url @@ -119,10 +120,11 @@ data AnnexRead = AnnexRead , sshstalecleaned :: TMVar Bool , signalactions :: TVar (M.Map SignalAction (Int -> IO ())) , transferrerpool :: TransferrerPool + , debugselector :: DebugSelector } -newAnnexRead :: IO AnnexRead -newAnnexRead = do +newAnnexRead :: GitConfig -> IO AnnexRead +newAnnexRead c = do emptyactivekeys <- newTVarIO M.empty emptyactiveremotes <- newMVar M.empty kh <- Keys.newDbHandle @@ -136,6 +138,7 @@ newAnnexRead = do , sshstalecleaned = sc , signalactions = si , transferrerpool = tp + , debugselector = debugSelectorFromGitConfig c } -- Values that can change while running an Annex action. @@ -261,7 +264,7 @@ new r = do r' <- Git.Config.read r let c = extractGitConfig FromGitConfig r' st <- newAnnexState c =<< fixupRepo r' c - rd <- newAnnexRead + rd <- newAnnexRead c return (st, rd) {- Performs an action in the Annex monad from a starting state, diff --git a/Annex/Debug.hs b/Annex/Debug.hs new file mode 100644 index 0000000000..4437147302 --- /dev/null +++ b/Annex/Debug.hs @@ -0,0 +1,30 @@ +{- git-annex debugging + - + - Copyright 2021 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.Debug ( + DebugSelector(..), + DebugSource(..), + debug, + fastDebug, + configureDebug, + debugSelectorFromGitConfig, + parseDebugSelector, +) where + +import Common +import qualified Annex +import Utility.Debug hiding (fastDebug) +import qualified Utility.Debug +import Annex.Debug.Utility + +-- | This is faster than using debug, because the DebugSelector +-- is read from the Annex monad, which avoids any IORef access overhead +-- when debugging is not enabled. +fastDebug :: DebugSource -> String -> Annex.Annex () +fastDebug src msg = do + selector <- Annex.getRead Annex.debugselector + liftIO $ Utility.Debug.fastDebug selector src msg diff --git a/Annex/Debug/Utility.hs b/Annex/Debug/Utility.hs new file mode 100644 index 0000000000..79186d840d --- /dev/null +++ b/Annex/Debug/Utility.hs @@ -0,0 +1,32 @@ +{- git-annex debugging, utility functions + - + - Copyright 2021 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.Debug.Utility ( + debugSelectorFromGitConfig, + parseDebugSelector, + DebugSelector, +) where + +import Types.GitConfig +import Utility.Debug +import Utility.Split +import Utility.FileSystemEncoding + +import qualified Data.ByteString as S + +debugSelectorFromGitConfig :: GitConfig -> DebugSelector +debugSelectorFromGitConfig = + maybe NoDebugSelector parseDebugSelector . annexDebugFilter + +parseDebugSelector :: String -> DebugSelector +parseDebugSelector = DebugSelector . matchDebugSource . splitSelectorNames + +splitSelectorNames :: String -> [S.ByteString] +splitSelectorNames = map encodeBS . splitc ',' + +matchDebugSource :: [S.ByteString] -> DebugSource -> Bool +matchDebugSource names (DebugSource s) = any (`S.isInfixOf` s) names diff --git a/CmdLine.hs b/CmdLine.hs index a2f6610d44..29b90eecd1 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -53,14 +53,14 @@ dispatch' subcommandname args fuzzy cmds allargs allcmds fields getgitrepo progn where go (Right g) = do g' <- Git.Config.read g - (cmd, seek, globalconfig) <- parsewith False cmdparser + (cmd, seek, globalsetter) <- parsewith False cmdparser (\a -> a (Just g')) O.handleParseResult - state <- Annex.new g' + state <- applyAnnexReadSetter globalsetter <$> Annex.new g' Annex.eval state $ do checkEnvironment forM_ fields $ uncurry Annex.setField - prepRunCommand cmd globalconfig + prepRunCommand cmd globalsetter startup performCommandAction cmd seek $ shutdown $ cmdnocommit cmd @@ -141,11 +141,14 @@ subCmdName argv = (name, args) | "-" `isPrefixOf` a = findname as (a:c) | otherwise = (Just a, reverse c ++ as) +-- | Note that the GlobalSetter must have already had its annexReadSetter +-- applied before entering the Annex monad; that cannot be changed while +-- running in the Annex monad. prepRunCommand :: Command -> GlobalSetter -> Annex () -prepRunCommand cmd globalconfig = do +prepRunCommand cmd globalsetter = do when (cmdnomessages cmd) $ Annex.setOutput QuietOutput - getParsed globalconfig + annexStateSetter globalsetter whenM (annexDebug <$> Annex.getGitConfig) $ enableDebugOutput diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs index ecb206b2cf..c03e453d96 100644 --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -43,55 +43,55 @@ import Annex.Concurrent -- although not always used. gitAnnexGlobalOptions :: [GlobalOption] gitAnnexGlobalOptions = commonGlobalOptions ++ - [ globalSetter setnumcopies $ option auto + [ globalOption (setAnnexState . setnumcopies) $ option auto ( long "numcopies" <> short 'N' <> metavar paramNumber <> help "override desired number of copies" <> hidden ) - , globalSetter setmincopies $ option auto + , globalOption (setAnnexState . setmincopies) $ option auto ( long "mincopies" <> short 'N' <> metavar paramNumber <> help "override minimum number of copies" <> hidden ) - , globalSetter (Remote.forceTrust Trusted) $ strOption + , globalOption (setAnnexState . Remote.forceTrust Trusted) $ strOption ( long "trust" <> metavar paramRemote <> help "deprecated, does not override trust setting" <> hidden <> completeRemotes ) - , globalSetter (Remote.forceTrust SemiTrusted) $ strOption + , globalOption (setAnnexState . Remote.forceTrust SemiTrusted) $ strOption ( long "semitrust" <> metavar paramRemote <> help "override trust setting back to default" <> hidden <> completeRemotes ) - , globalSetter (Remote.forceTrust UnTrusted) $ strOption + , globalOption (setAnnexState . Remote.forceTrust UnTrusted) $ strOption ( long "untrust" <> metavar paramRemote <> help "override trust setting to untrusted" <> hidden <> completeRemotes ) - , globalSetter setgitconfig $ strOption + , globalOption (setAnnexState . setgitconfig) $ strOption ( long "config" <> short 'c' <> metavar "NAME=VALUE" <> help "override git configuration setting" <> hidden ) - , globalSetter setuseragent $ strOption + , globalOption (setAnnexState . setuseragent) $ strOption ( long "user-agent" <> metavar paramName <> help "override default User-Agent" <> hidden ) - , globalFlag (toplevelWarning False "--trust-glacier no longer has any effect") + , globalFlag (setAnnexState $ toplevelWarning False "--trust-glacier no longer has any effect") ( long "trust-glacier" <> help "deprecated, does not trust Amazon Glacier inventory" <> hidden ) - , globalFlag (setdesktopnotify mkNotifyFinish) + , globalFlag (setAnnexState $ setdesktopnotify mkNotifyFinish) ( long "notify-finish" <> help "show desktop notification after transfer finishes" <> hidden ) - , globalFlag (setdesktopnotify mkNotifyStart) + , globalFlag (setAnnexState $ setdesktopnotify mkNotifyStart) ( long "notify-start" <> help "show desktop notification after transfer starts" <> hidden @@ -241,80 +241,81 @@ keyMatchingOptions = keyMatchingOptions' ++ combiningOptions ++ timeLimitOption keyMatchingOptions' :: [GlobalOption] keyMatchingOptions' = - [ globalSetter Limit.addIn $ strOption + [ globalOption (setAnnexState . Limit.addIn) $ strOption ( long "in" <> short 'i' <> metavar paramRemote <> help "match files present in a remote" <> hidden <> completeRemotes ) - , globalSetter Limit.addCopies $ strOption + , globalOption (setAnnexState . Limit.addCopies) $ strOption ( long "copies" <> short 'C' <> metavar paramRemote <> help "skip files with fewer copies" <> hidden ) - , globalSetter (Limit.addLackingCopies False) $ strOption + , globalOption (setAnnexState . Limit.addLackingCopies False) $ strOption ( long "lackingcopies" <> metavar paramNumber <> help "match files that need more copies" <> hidden ) - , globalSetter (Limit.addLackingCopies True) $ strOption + , globalOption (setAnnexState . Limit.addLackingCopies True) $ strOption ( long "approxlackingcopies" <> metavar paramNumber <> help "match files that need more copies (faster)" <> hidden ) - , globalSetter Limit.addInBackend $ strOption + , globalOption (setAnnexState . Limit.addInBackend) $ strOption ( long "inbackend" <> short 'B' <> metavar paramName <> help "match files using a key-value backend" <> hidden <> completeBackends ) - , globalFlag Limit.addSecureHash + , globalFlag (setAnnexState Limit.addSecureHash) ( long "securehash" <> help "match files using a cryptographically secure hash" <> hidden ) - , globalSetter Limit.addInAllGroup $ strOption + , globalOption (setAnnexState . Limit.addInAllGroup) $ strOption ( long "inallgroup" <> metavar paramGroup <> help "match files present in all remotes in a group" <> hidden ) - , globalSetter Limit.addMetaData $ strOption + , globalOption (setAnnexState . Limit.addMetaData) $ strOption ( long "metadata" <> metavar "FIELD=VALUE" <> help "match files with attached metadata" <> hidden ) - , globalFlag Limit.Wanted.addWantGet + , globalFlag (setAnnexState Limit.Wanted.addWantGet) ( long "want-get" <> help "match files the repository wants to get" <> hidden ) - , globalFlag Limit.Wanted.addWantDrop + , globalFlag (setAnnexState Limit.Wanted.addWantDrop) ( long "want-drop" <> help "match files the repository wants to drop" <> hidden ) - , globalSetter Limit.addAccessedWithin $ option (eitherReader parseDuration) - ( long "accessedwithin" - <> metavar paramTime - <> help "match files accessed within a time interval" - <> hidden - ) - , globalSetter Limit.addMimeType $ strOption + , globalOption (setAnnexState . Limit.addAccessedWithin) $ + option (eitherReader parseDuration) + ( long "accessedwithin" + <> metavar paramTime + <> help "match files accessed within a time interval" + <> hidden + ) + , globalOption (setAnnexState . Limit.addMimeType) $ strOption ( long "mimetype" <> metavar paramGlob <> help "match files by mime type" <> hidden ) - , globalSetter Limit.addMimeEncoding $ strOption + , globalOption (setAnnexState . Limit.addMimeEncoding) $ strOption ( long "mimeencoding" <> metavar paramGlob <> help "match files by mime encoding" <> hidden ) - , globalFlag Limit.addUnlocked + , globalFlag (setAnnexState Limit.addUnlocked) ( long "unlocked" <> help "match files that are unlocked" <> hidden ) - , globalFlag Limit.addLocked + , globalFlag (setAnnexState Limit.addLocked) ( long "locked" <> help "match files that are locked" <> hidden @@ -327,22 +328,22 @@ fileMatchingOptions lb = fileMatchingOptions' lb ++ combiningOptions ++ timeLimi fileMatchingOptions' :: Limit.LimitBy -> [GlobalOption] fileMatchingOptions' lb = - [ globalSetter Limit.addExclude $ strOption + [ globalOption (setAnnexState . Limit.addExclude) $ strOption ( long "exclude" <> short 'x' <> metavar paramGlob <> help "skip files matching the glob pattern" <> hidden ) - , globalSetter Limit.addInclude $ strOption + , globalOption (setAnnexState . Limit.addInclude) $ strOption ( long "include" <> short 'I' <> metavar paramGlob <> help "limit to files matching the glob pattern" <> hidden ) - , globalSetter (Limit.addLargerThan lb) $ strOption + , globalOption (setAnnexState . Limit.addLargerThan lb) $ strOption ( long "largerthan" <> metavar paramSize <> help "match files larger than a size" <> hidden ) - , globalSetter (Limit.addSmallerThan lb) $ strOption + , globalOption (setAnnexState . Limit.addSmallerThan lb) $ strOption ( long "smallerthan" <> metavar paramSize <> help "match files smaller than a size" <> hidden @@ -358,17 +359,19 @@ combiningOptions = , shortopt ')' "close group of options" ] where - longopt o h = globalFlag (Limit.addSyntaxToken o) ( long o <> help h <> hidden ) - shortopt o h = globalFlag (Limit.addSyntaxToken [o]) ( short o <> help h <> hidden ) + longopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken o) + ( long o <> help h <> hidden ) + shortopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken [o]) + ( short o <> help h <> hidden ) jsonOptions :: [GlobalOption] jsonOptions = - [ globalFlag (Annex.setOutput (JSONOutput stdjsonoptions)) + [ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput stdjsonoptions)) ( long "json" <> short 'j' <> help "enable JSON output" <> hidden ) - , globalFlag (Annex.setOutput (JSONOutput jsonerrormessagesoptions)) + , globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonerrormessagesoptions)) ( long "json-error-messages" <> help "include error messages in JSON" <> hidden @@ -383,7 +386,7 @@ jsonOptions = jsonProgressOption :: [GlobalOption] jsonProgressOption = - [ globalFlag (Annex.setOutput (JSONOutput jsonoptions)) + [ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonoptions)) ( long "json-progress" <> help "include progress in JSON output" <> hidden @@ -399,7 +402,7 @@ jsonProgressOption = -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = - [ globalSetter (setConcurrency . ConcurrencyCmdLine) $ + [ globalOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $ option (maybeReader parseConcurrency) ( long "jobs" <> short 'J' <> metavar (paramNumber `paramOr` "cpus") @@ -410,14 +413,14 @@ jobsOption = timeLimitOption :: [GlobalOption] timeLimitOption = - [ globalSetter settimelimit $ option (eitherReader parseDuration) + [ globalOption settimelimit $ option (eitherReader parseDuration) ( long "time-limit" <> short 'T' <> metavar paramTime <> help "stop after the specified amount of time" <> hidden ) ] where - settimelimit duration = do + settimelimit duration = setAnnexState $ do start <- liftIO getPOSIXTime let cutoff = start + durationToPOSIXTime duration Annex.changeState $ \s -> s { Annex.timelimit = Just (duration, cutoff) } diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs index 2dcfc19396..55c3ae1ee7 100644 --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -74,7 +74,7 @@ addGlobalOptions c = c { cmdglobaloptions = globalOptions ++ cmdglobaloptions c globalOptions :: [GlobalOption] globalOptions = - globalSetter checkUUID (strOption + globalOption (setAnnexState . checkUUID) (strOption ( long "uuid" <> metavar paramUUID <> help "local repository uuid" )) diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs index 86b64bf519..44073f18bb 100644 --- a/CmdLine/GlobalSetter.hs +++ b/CmdLine/GlobalSetter.hs @@ -7,19 +7,30 @@ module CmdLine.GlobalSetter where -import Types.DeferredParse import Common import Annex +import Types.DeferredParse import Options.Applicative -globalFlag :: Annex () -> Mod FlagFields GlobalSetter -> GlobalOption -globalFlag setter = flag' (DeferredParse setter) +setAnnexState :: Annex () -> GlobalSetter +setAnnexState a = GlobalSetter a id + +setAnnexRead :: (AnnexRead -> AnnexRead) -> GlobalSetter +setAnnexRead f = GlobalSetter (return ()) f -globalSetter :: (v -> Annex ()) -> Parser v -> GlobalOption -globalSetter setter parser = DeferredParse . setter <$> parser +globalFlag :: GlobalSetter -> Mod FlagFields GlobalSetter -> GlobalOption +globalFlag = flag' +globalOption :: (v -> GlobalSetter) -> Parser v -> GlobalOption +globalOption mk parser = mk <$> parser + +-- | Combines a bunch of GlobalOptions together into a Parser +-- that returns a GlobalSetter that can be used to set all the options that +-- are enabled. parserGlobalOptions :: [GlobalOption] -> Parser GlobalSetter -parserGlobalOptions [] = DeferredParse <$> pure noop -parserGlobalOptions l = DeferredParse . mapM_ getParsed - <$> many (foldl1 (<|>) l) +parserGlobalOptions [] = pure mempty +parserGlobalOptions l = mconcat <$> many (foldl1 (<|>) l) + +applyAnnexReadSetter :: GlobalSetter -> (AnnexState, AnnexRead) -> (AnnexState, AnnexRead) +applyAnnexReadSetter gs (st, rd) = (st, annexReadSetter gs rd) diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs index e7597db6c5..305ef88dc2 100644 --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -20,46 +20,47 @@ import Types.GitConfig import Git.Types (ConfigKey(..)) import Git.Config import Utility.FileSystemEncoding +import Annex.Debug -- Global options accepted by both git-annex and git-annex-shell sub-commands. commonGlobalOptions :: [GlobalOption] commonGlobalOptions = - [ globalFlag (setforce True) + [ globalFlag (setAnnexState $ setforce True) ( long "force" <> help "allow actions that may lose annexed data" <> hidden ) - , globalFlag (setfast True) + , globalFlag (setAnnexState $ setfast True) ( long "fast" <> short 'F' <> help "avoid slow operations" <> hidden ) - , globalFlag (Annex.setOutput QuietOutput) + , globalFlag (setAnnexState $ Annex.setOutput QuietOutput) ( long "quiet" <> short 'q' <> help "avoid verbose output" <> hidden ) - , globalFlag (Annex.setOutput NormalOutput) + , globalFlag (setAnnexState $ Annex.setOutput NormalOutput) ( long "verbose" <> short 'v' <> help "allow verbose output (default)" <> hidden ) - , globalFlag (setdebug True) + , globalFlag (setAnnexState $ setdebug True) ( long "debug" <> short 'd' <> help "show debug messages" <> hidden ) - , globalFlag (setdebug False) + , globalFlag (setAnnexState $ setdebug False) ( long "no-debug" <> help "don't show debug messages" <> hidden ) - , globalSetter setdebugfilter $ strOption + , globalOption setdebugfilter $ strOption ( long "debugfilter" <> metavar "NAME[,NAME..]" <> help "show debug messages coming from a module" <> hidden ) - , globalSetter setforcebackend $ strOption + , globalOption setforcebackend $ strOption ( long "backend" <> short 'b' <> metavar paramName <> help "specify key-value backend to use" <> hidden @@ -67,13 +68,26 @@ commonGlobalOptions = ] where setforce v = Annex.changeState $ \s -> s { Annex.force = v } + setfast v = Annex.changeState $ \s -> s { Annex.fast = v } - setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v } + + setforcebackend v = setAnnexState $ + Annex.changeState $ \s -> s { Annex.forcebackend = Just v } + -- Overriding this way, rather than just setting annexDebug -- makes the config be passed on to any git-annex child processes. setdebug v = Annex.addGitConfigOverride $ decodeBS' $ debugconfig <> "=" <> boolConfig' v - setdebugfilter v = Annex.addGitConfigOverride $ - decodeBS' (debugfilterconfig <> "=") ++ v + + setdebugfilter v = mconcat + [ setAnnexRead $ \rd -> rd + { Annex.debugselector = parseDebugSelector v + } + -- Also set in git config so it will be passed on to any + -- git-annex child processes. + , setAnnexState $ Annex.addGitConfigOverride $ + decodeBS' (debugfilterconfig <> "=") ++ v + ] + (ConfigKey debugconfig) = annexConfig "debug" (ConfigKey debugfilterconfig) = annexConfig "debugfilter" diff --git a/Messages.hs b/Messages.hs index 81a286a3b1..3679120082 100644 --- a/Messages.hs +++ b/Messages.hs @@ -64,7 +64,7 @@ import Types.Command (StartMessage(..), SeekInput) import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent -import Utility.Debug +import Annex.Debug import Annex.Concurrent.Utility import qualified Messages.JSON as JSON import qualified Annex @@ -251,7 +251,7 @@ showRaw s = outputMessage JSON.none (s <> "\n") setupConsole :: IO () setupConsole = do dd <- debugDisplayer - configureDebug dd mempty + configureDebug dd (DebugSelector (const False)) {- 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 - a file or a pipe. -} @@ -260,17 +260,14 @@ setupConsole = do enableDebugOutput :: Annex () enableDebugOutput = do - names <- map encodeBS . annexDebugFilter <$> Annex.getGitConfig - let selector - | null names = const True - | otherwise = \(DebugSource s) -> any (`S.isInfixOf` s) names + selector <- Annex.getRead Annex.debugselector dd <- liftIO debugDisplayer - liftIO $ configureDebug dd (DebugSelector selector) + liftIO $ configureDebug dd selector disableDebugOutput :: Annex () disableDebugOutput = liftIO $ do dd <- debugDisplayer - configureDebug dd mempty + configureDebug dd (DebugSelector (const False)) debugDisplayer :: IO (S.ByteString -> IO ()) debugDisplayer = do diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs index 7cfeb148ee..58d40f2fc8 100644 --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -1,6 +1,6 @@ {- git-annex deferred parse values - - - Copyright 2015 Joey Hess + - Copyright 2015-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,6 +12,8 @@ module Types.DeferredParse where import Annex import Options.Applicative +import qualified Data.Semigroup as Sem +import Prelude -- Some values cannot be fully parsed without performing an action. -- The action may be expensive, so it's best to call finishParse on such a @@ -36,6 +38,20 @@ instance DeferredParseClass (Maybe (DeferredParse a)) where instance DeferredParseClass [DeferredParse a] where finishParse v = mapM finishParse v --- Use when the Annex action modifies Annex state. -type GlobalSetter = DeferredParse () type GlobalOption = Parser GlobalSetter + +-- Used for global options that can modify Annex state by running +-- an arbitrary action in it, and can also set up AnnexRead. +data GlobalSetter = GlobalSetter + { annexStateSetter :: Annex () + , annexReadSetter :: AnnexRead -> AnnexRead + } + +instance Sem.Semigroup GlobalSetter where + a <> b = GlobalSetter + { annexStateSetter = annexStateSetter a >> annexStateSetter b + , annexReadSetter = annexReadSetter b . annexReadSetter a + } + +instance Monoid GlobalSetter where + mempty = GlobalSetter (return ()) id diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 32717d23ce..b5b66f0c77 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -90,7 +90,7 @@ data GitConfig = GitConfig , annexSyncContent :: GlobalConfigurable Bool , annexSyncOnlyAnnex :: GlobalConfigurable Bool , annexDebug :: Bool - , annexDebugFilter :: [String] + , annexDebugFilter :: Maybe String , annexWebOptions :: [String] , annexYoutubeDlOptions :: [String] , annexAriaTorrentOptions :: [String] @@ -171,8 +171,7 @@ extractGitConfig configsource r = GitConfig , annexSyncOnlyAnnex = configurable False $ getmaybebool (annexConfig "synconlyannex") , annexDebug = getbool (annexConfig "debug") False - , annexDebugFilter = maybe [] (splitc ',') $ - getmaybe (annexConfig "debugfilter") + , annexDebugFilter = getmaybe (annexConfig "debugfilter") , annexWebOptions = getwords (annexConfig "web-options") , annexYoutubeDlOptions = getwords (annexConfig "youtube-dl-options") , annexAriaTorrentOptions = getwords (annexConfig "aria-torrent-options") diff --git a/git-annex.cabal b/git-annex.cabal index 6860216dbe..615fee876a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -627,6 +627,8 @@ Executable git-annex Annex.Content.LowLevel Annex.Content.PointerFile Annex.CurrentBranch + Annex.Debug + Annex.Debug.Utility Annex.Difference Annex.DirHashes Annex.Drop -- 2.30.2