在Haskell中存储多态回调

Question

提前,抱歉这篇长篇文章.

我正在Haskell中编写一个事件驱动的应用程序,因此我需要存储几个回调函数以供进一步使用.我希望这样的回调是:

• 富集:使用的ReaderT,ErrorT,StateT而非裸IO秒;
• 多态的:类型(MonadIO m, MonadReader MyContext m, MonadState MyState m, MonadError MyError m) => m (),而不是ReaderT MyContext (StateT MyState (ErrorT MyError IO)))

为简单起见,让我们忘记State和Error层.

我开始写一个存储在里面的所有回调的记录MyContext,例如:

    data MyContext = MyContext { _callbacks :: Callbacks {- etc -} }

    -- In this example, 2 callbacks only
    data Callbacks = Callbacks {
        _callback1 :: IORef (m ()),
        _callback2 :: IORef (m ())}

主要问题是:在哪里放置类型类约束m？我尝试了以下,但没有编译:

• 我想我可能参数Callbacks有m,例如:

  data (MonadIO m, MonadReader (MyContext m) m) => Callbacks m = Callbacks {
     _callback1 :: IORef (m ()),
     _callback2 :: IORef (m ())}
  

  作为其中Callbacks的一部分MyContext,后者也必须进行参数化,并导致无限类型问题(MonadReader (MyContext m) m).

• 然后我想到使用存在量词:

  data Callbacks = forall m . (MonadIO m, MonadReader MyContext m) => Callbacks {
     _callback1 :: IORef (m ()),
     _callback2 :: IORef (m ())}
  

  它似乎工作正常,直到我编写注册新回调的实际代码Callbacks:

  register :: (MonadIO m, MonadReader MyContext m) => m () -> m ()
  register f = do
    (Callbacks { _callback1 = ref1 }) <- asks _callbacks -- Note the necessary use of pattern matching
    liftIO $ modifyIORef ref1 (const f)
  

  但我得到以下错误(这里简化):

  Could not deduce (m ~ m1)
    from the context (MonadIO m, MonadReader MyContext m)
      bound by the type signature for
           register :: (MonadIO m, MonadReader MyContext m) => m () -> m ()
    or from (MonadIO m1, MonadReader MyContext m1)
      bound by a pattern with constructor
           Callbacks :: forall (m :: * -> *).
                     (MonadIO m, MonadReader MyContext m) =>
                     IORef (m ())
                     -> IORef (m ())
                     -> Callbacks,
    Expected type: m1 ()
    Actual type: m ()
  

  我无法找到解决方法.

如果有人能够启发我,我将非常感激.什么是的,如果有,这种设计的好办法吗？

提前感谢您的意见.

[编辑]据我所知ysdx的答案,我尝试参数化我的数据类型m而不强加任何类型类约束,但后来我无法创建Callbacks一个实例Data.Default; 写这样的东西:

instance (MonadIO m, MonadReader (MyContext m) m) => Default (Callbacks m) where
  def = Callbacks {
    _callback1 = {- something that makes explicit use of the Reader layer -},
    _callback2 = return ()}

...导致GHC抱怨:

Variable occurs more often in a constraint than in the instance head
  in the constraint: MonadReader (MyContext m) m

它建议使用UndecidableInstances,但我听说这是一件非常糟糕的事情,虽然我不知道为什么.这是否意味着我必须放弃使用Data.Default？

Answer 1

简单的适应(使事情编译):

data MyContext m = MyContext { _callbacks :: Callbacks m }

data Callbacks m = Callbacks {
  _callback1 :: IORef (m ()),
  _callback2 :: IORef (m ())}

-- Needs FlexibleContexts:
register :: (MonadIO m, MonadReader (MyContext m) m) => m () -> m ()
register f = do
  (Callbacks { _callback1 = ref1 }) <- asks _callbacks
  liftIO $ modifyIORef ref1 (const f)

但是-XFlexibleContexts是必需的.

你真的需要IORef吗？为什么不使用简单的状态monad？

import Control.Monad.State
import Control.Monad.Reader.Class
import Control.Monad.Trans

data Callbacks m = Callbacks {
  _callback1 :: m (),
  _callback2 :: m ()
  }

-- Create a "new" MonadTransformer layer (specialization of StateT):

class Monad m => MonadCallback m where
  getCallbacks :: m (Callbacks m)
  setCallbacks :: Callbacks m -> m ()

newtype CallbackT m a = CallbackT (StateT (Callbacks (CallbackT m) ) m a)

unwrap (CallbackT x) = x

instance Monad m => Monad (CallbackT m) where
  CallbackT x >>= f = CallbackT (x >>= f')
    where f' x = unwrap $ f x
  return a =  CallbackT $ return a
instance Monad m => MonadCallback (CallbackT m) where
  getCallbacks = CallbackT $ get
  setCallbacks c = CallbackT $ put c
instance MonadIO m => MonadIO (CallbackT m) where
  liftIO m = CallbackT $ liftIO m
instance MonadTrans (CallbackT) where
  lift m = CallbackT $ lift m
-- TODO, add other instances

-- Helpers:

getCallback1 = do
  c <- getCallbacks
  return $ _callback1 c

-- This is you "register" function:
setCallback1 :: (Monad m, MonadCallback m) => m () -> m ()
setCallback1 f = do
  callbacks <- getCallbacks
  setCallbacks $ callbacks { _callback1 = f }   

-- Test:

test :: CallbackT IO ()
test = do
  c <- getCallbacks
  _callback1 c
  _callback2 c

main = runCallbackT test s
  where s = Callbacks { _callback1 = lift $ print "a" (), _callback2 = lift $ print "b" }

即使没有MonadIO,此代码也能正常工作.

定义"默认"似乎工作正常:

instance (MonadIO m, MonadCallback m) => Default (Callbacks m) where
def = Callbacks {
  _callback1 = getCallbacks >>= \c -> setCallbacks $ c { _callback2 = _callback1 c },
  _callback2 = return ()}