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:
parent
ec0bac9d73
commit
4e765327ca
18 changed files with 259 additions and 210 deletions
83
Assistant/Monad.hs
Normal file
83
Assistant/Monad.hs
Normal 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
|
Loading…
Add table
Add a link
Reference in a new issue