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.

1 files changed, 83 insertions, 0 deletions

diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
new file mode 100644
index 000000000..fa982b45e
--- /dev/null
+++ b/Assistant/Monad.hs
@@ -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