diff options
author | Joey Hess <joey@kitenet.net> | 2012-10-29 02:21:04 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-10-29 02:21:04 -0400 |
commit | 579f63b6b756ca51b8f9fe53c3e668500718d91f (patch) | |
tree | 20039581df67e034ef434749d37de41e9802d21d /Assistant/Monad.hs | |
parent | 040f68d628120e112e22bfb7100f9650dec940c8 (diff) |
Assistant monad, stage 2.5
Converted several threads to run in the monad.
Added a lot of useful combinators for working with the monad.
Now the monad includes the name of the thread.
Some debugging messages are disabled pending converting other threads.
Diffstat (limited to 'Assistant/Monad.hs')
-rw-r--r-- | Assistant/Monad.hs | 40 |
1 files changed, 36 insertions, 4 deletions
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index fa982b45e..ef9e7a4cb 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -13,7 +13,12 @@ module Assistant.Monad ( newAssistantData, runAssistant, getAssistant, - liftAnnex + liftAnnex, + (<~>), + (<<~), + daemonStatus, + asIO, + asIO2, ) where import "mtl" Control.Monad.Reader @@ -43,8 +48,9 @@ instance MonadBase IO Assistant where liftBase = Assistant . liftBase data AssistantData = AssistantData - { threadState :: ThreadState - , daemonStatus :: DaemonStatusHandle + { threadName :: String + , threadState :: ThreadState + , daemonStatusHandle :: DaemonStatusHandle , scanRemoteMap :: ScanRemoteMap , transferQueue :: TransferQueue , transferSlots :: TransferSlots @@ -57,7 +63,8 @@ data AssistantData = AssistantData newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData newAssistantData st dstatus = AssistantData - <$> pure st + <$> pure "main" + <*> pure st <*> pure dstatus <*> newScanRemoteMap <*> newTransferQueue @@ -81,3 +88,28 @@ liftAnnex :: Annex a -> Assistant a 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 a d + +{- Creates an IO action that will run an Assistant action when run. -} +asIO :: (a -> Assistant b) -> Assistant (a -> IO b) +asIO a = do + d <- reader id + return $ \v -> runAssistant (a v) d + +{- Creates an IO action that will run an Assistant action when run. -} +asIO2 :: (a -> b -> Assistant c) -> Assistant (a -> b -> IO c) +asIO2 a = do + d <- reader id + return $ \v1 v2 -> runAssistant (a v1 v2) d + +{- Runs an IO action on a selected field of the AssistantData. -} +(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b +io <<~ v = reader v >>= liftIO . io + +daemonStatus :: Assistant DaemonStatus +daemonStatus = getDaemonStatus <<~ daemonStatusHandle |