Assistant monad, stage 1

This adds the Assistant monad, and an AssistantData structure.
So far, none of the assistant's threads run in the monad yet.
This commit is contained in:
Joey Hess 2012-10-29 00:15:43 -04:00
parent ec0bac9d73
commit 4e765327ca
18 changed files with 259 additions and 210 deletions

83
Assistant/Monad.hs Normal file
View file

@ -0,0 +1,83 @@
{- git-annex assistant monad
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}
module Assistant.Monad (
Assistant,
AssistantData(..),
newAssistantData,
runAssistant,
getAssistant,
liftAnnex
) where
import "mtl" Control.Monad.Reader
import Control.Monad.Base (liftBase, MonadBase)
import Common.Annex
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.ScanRemotes
import Assistant.TransferQueue
import Assistant.TransferSlots
import Assistant.Pushes
import Assistant.Commits
import Assistant.Changes
import Assistant.BranchChange
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving (
Monad,
MonadIO,
MonadReader AssistantData,
Functor,
Applicative
)
instance MonadBase IO Assistant where
liftBase = Assistant . liftBase
data AssistantData = AssistantData
{ threadState :: ThreadState
, daemonStatus :: DaemonStatusHandle
, scanRemoteMap :: ScanRemoteMap
, transferQueue :: TransferQueue
, transferSlots :: TransferSlots
, pushNotifier :: PushNotifier
, failedPushMap :: FailedPushMap
, commitChan :: CommitChan
, changeChan :: ChangeChan
, branchChangeHandle :: BranchChangeHandle
}
newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
newAssistantData st dstatus = AssistantData
<$> pure st
<*> pure dstatus
<*> newScanRemoteMap
<*> newTransferQueue
<*> newTransferSlots
<*> newPushNotifier
<*> newFailedPushMap
<*> newCommitChan
<*> newChangeChan
<*> newBranchChangeHandle
runAssistant :: Assistant a -> AssistantData -> IO a
runAssistant a = runReaderT (mkAssistant a)
getAssistant :: (AssistantData -> a) -> Assistant a
getAssistant = reader
{- Runs an action in the git-annex monad. Note that the same monad state
- is shared amoung all assistant threads, so only one of these can run at
- a time. Therefore, long-duration actions should be avoided. -}
liftAnnex :: Annex a -> Assistant a
liftAnnex a = do
st <- reader threadState
liftIO $ runThreadState st a