MonadBaseControl：如何解除ThreadGroup

Question

在模塊Control.Concurrent.Thread.Group threads包中有一個函數forkIO ：

forkIO :: ThreadGroup -> IO α -> IO (ThreadId, IO (Result α))

我想從monad-control使用MonadBaseControl來解除它。 這是我的嘗試：

fork :: (MonadBase IO m) => TG.ThreadGroup -> m α -> m (ThreadId, m (Result α))
fork tg action = control (\runInBase -> TG.forkIO tg (runInBase action))

這是錯誤消息：

Couldn't match type `(ThreadId, IO (Result (StM m α)))'
              with `StM m (ThreadId, m (Result α))'
Expected type: IO (StM m (ThreadId, m (Result α)))
  Actual type: IO (ThreadId, IO (Result (StM m α)))
In the return type of a call of `TG.forkIO'
In the expression: TG.forkIO tg (runInBase action)
In the first argument of `control', namely
  `(\ runInBase -> TG.forkIO tg (runInBase action))'

要使類型匹配需要更改的內容？

Answer 1

主要問題是IO a forkIO IO a參數。 要在IO分叉ma動作，我們需要一種方法來將ma運行到IO a 。 為此，我們可以嘗試制作具有runBase :: MonadBase bm => ma -> ba方法的monad類，但很少有趣的變換器可以提供。 如果我們考慮例如StateT轉換器，它可以弄清楚如果首先有機會觀察它自己的狀態，如何用runStateT在base monad中運行一些東西。

runFork :: Monad m => StateT s m a -> StateT s m (m b)
runFork x = do
    s <- get
    return $ do
        (a, s') <- runStateT x s
        return a

這表明類型為runForkBase :: MonadBase bm => ma -> m (ba) ，我們將為以下類型類決定。

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

import Control.Monad.Base

class (MonadBase b m) => MonadRunForkBase b m | m -> b where
    runForkBase :: m a -> m (b a)

我在名稱中添加了Fork這個詞，以強調未來的狀態變化通常不會在兩個期貨之間分享。 出於這個原因，像WriterT這樣可以提供runBase的少數有趣的變換器只提供了一個無趣的runBase ; 它們會產生永遠不會被觀察到的副作用。

我們可以使用由MonadRunForkBase IO m實例提供的有限降低形式來編寫類似fork的東西。 我要lift正常forkIO從底部而不是從一個線程 ，你可以做同樣的方式。

{-# LANGUAGE FlexibleContexts #-}

import Control.Concurrent

forkInIO :: (MonadRunForkBase IO m) => m () -> m ThreadId
forkInIO action = runForkBase action >>= liftBase . forkIO

實例

這提出了一個問題，“我們可以為MonadRunForkBase實例提供哪些變換器”？ 直接蝙蝠，我們可以輕松地為任何具有MonadBase實例的基礎monad提供它們

import Control.Monad.Trans.Identity
import GHC.Conc.Sync (STM)

instance MonadRunForkBase [] [] where runForkBase = return 
instance MonadRunForkBase IO IO where runForkBase = return
instance MonadRunForkBase STM STM where runForkBase = return
instance MonadRunForkBase Maybe Maybe where runForkBase = return
instance MonadRunForkBase Identity Identity where runForkBase = return

對於變形金剛來說，通常更容易構建這樣的功能。 這是可以在直接底層monad中運行fork的變換器類。

import Control.Monad.Trans.Class

class (MonadTrans t) => MonadTransRunFork t where
    runFork :: Monad m => t m a -> t m (m a)

我們可以提供默認實現，以便在基礎中一直運行

runForkBaseDefault :: (Monad (t m), MonadTransRunFork t, MonadRunForkBase b m) =>
                      t m a -> t m (b a)
runForkBaseDefault = (>>= lift . runForkBase) . runFork

這讓我們完成了MonadRunForkBase例如StateT分兩步進行。 首先，我們將使用runFork從上面做出MonadTransRunFork實例

import Control.Monad
import qualified Control.Monad.Trans.State.Lazy as State

instance MonadTransRunFork (State.StateT s) where
    runFork x = State.get >>= return . liftM fst . State.runStateT x

然后我們將使用默認值來提供MonadRunForkBase實例。

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

instance (MonadRunForkBase b m) => MonadRunForkBase b (State.StateT s m) where
    runForkBase = runForkBaseDefault

我們可以為RWS做同樣的事情

import qualified Control.Monad.Trans.RWS.Lazy as RWS

instance (Monoid w) => MonadTransRunFork (RWS.RWST r w s) where
    runFork x = do
        r <- RWS.ask
        s <- RWS.get
        return $ do 
            (a, s', w') <- RWS.runRWST x r s
            return a

instance (MonadRunForkBase b m, Monoid w) => MonadRunForkBase b (RWS.RWST r w s m) where
    runForkBase = runForkBaseDefault

MonadBaseControl

與我們在MonadRunForkBase中開發的MonadBaseControl ， monad-control中的MonadBaseControl並未假設“未來的狀態變化通常不會在兩個期貨之間共享”。 MonadBaseContol和control努力使用restoreM :: StM ma -> ma從控制結構中的分支恢復狀態。 對於forkIO ，這不會產生問題; 使用forkIO是MonadBaseControl文檔中提供的示例。 由於返回了額外的m (Result a) ，這對於forkIO是一個小問題。

我們想要的m (Result a)實際上將作為IO (Result (StM ma)) 。 我們可以擺脫IO並用帶有liftBase的m替換它，留下m (Result (StM ma)) 。 我們可以將StM ma轉換為恢復狀態的ma ，然后使用restoreM返回a ，但它被卡在Result ~ Either SomeException 。 Either l是restoreM函數，所以我們可以在其中的任何地方應用restoreM ，將類型簡化為m (Result (ma)) 。 Either l也是Traversable ，並且對於任何Traversable t我們總是可以將其交換一個內部Monad或Applicative與sequenceA :: t (fa) -> f (ta) 在這種情況下，我們可以使用專用mapM ，它是fmap和sequenceA的組合，只有Monad約束。 這將給出m (m (Result a)) ，並且m s將通過Monad中的連接或僅使用>>= 。 這導致了

{-# LANGUAGE FlexibleContexts #-}

import Control.Concurrent
import Control.Concurrent.Thread
import qualified Control.Concurrent.Thread.Group as TG

import Control.Monad.Base
import Control.Monad.Trans.Control

import Data.Functor
import Data.Traversable
import Prelude hiding (mapM)

fork :: (MonadBaseControl IO m) =>
        TG.ThreadGroup -> m a -> m (ThreadId, m (Result a))
fork tg action = do
    (tid, r) <- liftBaseWith (\runInBase -> TG.forkIO tg (runInBase action))    
    return (tid, liftBase r >>= mapM restoreM)

當我們在原始線程中運行m (Result a)時，它會將狀態從分叉線程復制到原始線程，這可能很有用。 如果要在讀取Result后恢復主線程的狀態，則需要先捕獲它。 checkpoint將捕獲整個狀態並返回一個動作來恢復它。

checkpoint :: MonadBaseControl b m => m (m ())
checkpoint = liftBaseWith (\runInBase -> runInBase (return ()))
             >>= return . restoreM

一個完整的例子將展示兩個線程對狀態的影響。 無論在另一個線程中修改狀態的努力如何，兩個線程都從fork發生時獲得狀態。 當我們在主線程中等待結果時，主線程中的狀態被設置為分叉線程中的狀態。 我們可以通過運行checkpoint創建的操作來獲取主線程的狀態。

import Control.Monad.State hiding (mapM)

example :: (MonadState String m, MonadBase IO m, MonadBaseControl IO m) => m ()
example = do    
    get >>= liftBase . putStrLn
    tg <- liftBase TG.new
    (_, getResult) <- fork tg (get >>= put . ("In Fork:" ++)  >> return 7)
    get >>= put . ("In Main:" ++) 
    revert <- checkpoint
    result <- getResult
    (liftBase . print) result
    get >>= liftBase . putStrLn
    revert
    get >>= liftBase . putStrLn

main = do
    runStateT example "Initial"
    return ()

這輸出

Initial
Right 7
In Fork:Initial
In Main:Initial