aaba83795b
This uses a DebugSelector, rather than debug levels, which will allow for a later option like --debug-from=Process to only see debuging about running processes. The module name that contains the thing being debugged is used as the DebugSelector (in most cases; does not need to be a hard and fast rule). Debug calls were changed to add that. hslogger did not display that first parameter to debugM, but the DebugSelector does get displayed. Also fastDebug will allow doing debugging in places that are used in tight loops, with the DebugSelector coming from the Annex Reader essentially for free. Not done yet.
143 lines
3.8 KiB
Haskell
143 lines
3.8 KiB
Haskell
{- git-annex assistant monad
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
|
|
|
|
module Assistant.Monad (
|
|
Assistant,
|
|
AssistantData(..),
|
|
newAssistantData,
|
|
runAssistant,
|
|
getAssistant,
|
|
LiftAnnex,
|
|
liftAnnex,
|
|
(<~>),
|
|
(<<~),
|
|
asIO,
|
|
asIO1,
|
|
asIO2,
|
|
ThreadName,
|
|
debug,
|
|
) where
|
|
|
|
import "mtl" Control.Monad.Reader
|
|
import qualified Control.Monad.Fail as Fail
|
|
|
|
import Annex.Common
|
|
import Assistant.Types.ThreadedMonad
|
|
import Assistant.Types.DaemonStatus
|
|
import Assistant.Types.ScanRemotes
|
|
import Assistant.Types.TransferQueue
|
|
import Assistant.Types.TransferSlots
|
|
import Assistant.Types.Pushes
|
|
import Assistant.Types.BranchChange
|
|
import Assistant.Types.Commits
|
|
import Assistant.Types.Changes
|
|
import Assistant.Types.RepoProblem
|
|
import Assistant.Types.ThreadName
|
|
import Assistant.Types.RemoteControl
|
|
import Assistant.Types.CredPairCache
|
|
import qualified Utility.Debug as Debug
|
|
|
|
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
|
|
deriving (
|
|
Monad,
|
|
MonadIO,
|
|
MonadReader AssistantData,
|
|
MonadCatch,
|
|
MonadThrow,
|
|
MonadMask,
|
|
Fail.MonadFail,
|
|
Functor,
|
|
Applicative
|
|
)
|
|
|
|
data AssistantData = AssistantData
|
|
{ threadName :: ThreadName
|
|
, threadState :: ThreadState
|
|
, daemonStatusHandle :: DaemonStatusHandle
|
|
, scanRemoteMap :: ScanRemoteMap
|
|
, transferQueue :: TransferQueue
|
|
, transferSlots :: TransferSlots
|
|
, failedPushMap :: FailedPushMap
|
|
, failedExportMap :: FailedPushMap
|
|
, commitChan :: CommitChan
|
|
, exportCommitChan :: CommitChan
|
|
, changePool :: ChangePool
|
|
, repoProblemChan :: RepoProblemChan
|
|
, branchChangeHandle :: BranchChangeHandle
|
|
, remoteControl :: RemoteControl
|
|
, credPairCache :: CredPairCache
|
|
}
|
|
|
|
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
|
|
newAssistantData st dstatus = AssistantData
|
|
<$> pure (ThreadName "main")
|
|
<*> pure st
|
|
<*> pure dstatus
|
|
<*> newScanRemoteMap
|
|
<*> newTransferQueue
|
|
<*> newTransferSlots
|
|
<*> newFailedPushMap
|
|
<*> newFailedPushMap
|
|
<*> newCommitChan
|
|
<*> newCommitChan
|
|
<*> newChangePool
|
|
<*> newRepoProblemChan
|
|
<*> newBranchChangeHandle
|
|
<*> newRemoteControl
|
|
<*> newCredPairCache
|
|
|
|
runAssistant :: AssistantData -> Assistant a -> IO a
|
|
runAssistant d a = runReaderT (mkAssistant a) d
|
|
|
|
getAssistant :: (AssistantData -> a) -> Assistant a
|
|
getAssistant = reader
|
|
|
|
{- Using a type class for lifting into the annex monad allows
|
|
- easily lifting to it from multiple different monads. -}
|
|
class LiftAnnex m where
|
|
liftAnnex :: Annex a -> m a
|
|
|
|
{- Runs an action in the git-annex monad. Note that the same monad state
|
|
- is shared among all assistant threads, so only one of these can run at
|
|
- a time. Therefore, long-duration actions should be avoided. -}
|
|
instance LiftAnnex Assistant where
|
|
liftAnnex a = do
|
|
st <- reader threadState
|
|
liftIO $ runThreadState st a
|
|
|
|
{- Runs an IO action, passing it an IO action that runs an Assistant action. -}
|
|
(<~>) :: (IO a -> IO b) -> Assistant a -> Assistant b
|
|
io <~> a = do
|
|
d <- reader id
|
|
liftIO $ io $ runAssistant d a
|
|
|
|
{- Creates an IO action that will run an Assistant action when run. -}
|
|
asIO :: Assistant a -> Assistant (IO a)
|
|
asIO a = do
|
|
d <- reader id
|
|
return $ runAssistant d a
|
|
|
|
asIO1 :: (a -> Assistant b) -> Assistant (a -> IO b)
|
|
asIO1 a = do
|
|
d <- reader id
|
|
return $ \v -> runAssistant d $ a v
|
|
|
|
asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c)
|
|
asIO2 a = do
|
|
d <- reader id
|
|
return $ \v1 v2 -> runAssistant d (a v1 v2)
|
|
|
|
{- Runs an IO action on a selected field of the AssistantData. -}
|
|
(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
|
|
io <<~ v = reader v >>= liftIO . io
|
|
|
|
debug :: [String] -> Assistant ()
|
|
debug ws = do
|
|
ThreadName name <- getAssistant threadName
|
|
liftIO $ Debug.debug (Debug.DebugSource (encodeBS name)) (unwords ws)
|