summaryrefslogtreecommitdiff
path: root/Assistant/Monad.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-10-29 00:15:43 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-10-29 00:15:43 -0400
commit040f68d628120e112e22bfb7100f9650dec940c8 (patch)
tree7b0945f04cb23f09e8f2a77cf1c409cb058af84f /Assistant/Monad.hs
parent9dd50063b98020add52672864922308ebb479280 (diff)
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.
Diffstat (limited to 'Assistant/Monad.hs')
-rw-r--r--Assistant/Monad.hs83
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