这是与我的模块here有关的问题,并且已简化了一点。它也与this前一个问题有关,在该问题中我简化了我的问题,但没有得到我想要的答案。我希望这不是太具体,如果您认为更好的话,请更改标题。

背景

我的模块使用并发chan,分为读取端和写入端。我使用带有关联类型同义词的特殊类来支持多态 channel “joins”:

{-# LANGUAGE TypeFamilies #-}

class Sources s where
    type Joined s
    newJoinedChan :: IO (s, Messages (Joined s)) -- NOT EXPORTED

--output and input sides of channel:
data Messages a  -- NOT EXPORTED
data Mailbox a

instance Sources (Mailbox a) where
    type Joined (Mailbox a) = a
    newJoinedChan = undefined

instance (Sources a, Sources b)=> Sources (a,b) where
    type Joined (a,b) = (Joined a, Joined b)
    newJoinedChan = undefined

-- and so on for tuples of 3,4,5...

上面的代码使我们可以执行以下操作:
example = do
    (mb ,        msgsA) <- newJoinedChan
    ((mb1, mb2), msgsB) <- newJoinedChan
    --say that: msgsA, msgsB :: Messages (Int,Int)
    --and:      mb :: Mailbox (Int,Int)
    --          mb1,mb2 :: Mailbox Int

我们有一个称为Behavior的递归操作,我们可以对从 channel 的“读取”端拉出的消息进行处理:
newtype Behavior a = Behavior (a -> IO (Behavior a))
runBehaviorOn :: Behavior a -> Messages a -> IO ()  -- NOT EXPORTED

这将使我们能够在Behavior (Int,Int)msgsA上运行msgsB,在第二种情况下,它接收到的元组中的两个Int实际上都来自单独的Mailbox es。

在公开的spawn函数中,所有这些都为用户捆绑在一起
spawn :: (Sources s) => Behavior (Joined s) -> IO s

...调用newJoinedChanrunBehaviorOn,并返回输入的Sources

我想做什么

我希望用户能够创建任意产品类型(而不仅仅是元组)的Behavior,因此例如我们可以在上面的示例Behavior (Pair Int Int)上运行Messages。我想使用GHC.Generics进行此操作,同时仍然具有一个多态的Sources,但是无法使其正常工作。
spawn :: (Sources s, Generic (Joined s), Rep (Joined s) ~ ??) => Behavior (Joined s) -> IO s

以上示例中API中实际公开的部分是fst操作的newJoinedChanBehavior,因此可接受的解决方案可以修改runBehaviorOnsndnewJoinedChan中的一个或全部。

我还将在上面扩展API以支持Behavior (Either a b)之类的总和(尚未实现),因此我希望GHC.Generics对我有用。

问题
  • 有没有一种方法可以扩展上述API以支持任意Generic a=> Behavior a
  • 如果不使用GHC的泛型,是否还有其他方法可以使我以最小的最终用户痛苦获得我想要的API(即,他们只需要在其类型中添加一个派生子句)即可?例如与Data.Data吗?
  • 最佳答案

    也许是这样的吗?

    {-# LANGUAGE TypeFamilies, DeriveGeneric, DefaultSignatures, TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
    
    import Control.Arrow
    import GHC.Generics
    
    class Sources s where
        type Joined s
        newJoinedChan :: IO (s, Messages (Joined s)) -- NOT EXPORTED
        default newJoinedChan :: (Generic s, SourcesG (Rep s)) => IO (s, Messages (JoinedG (Rep s)))
        newJoinedChan = fmap (first to) newJoinedChanG
    
    class SourcesG g where
        type JoinedG g
        newJoinedChanG :: IO (g a, Messages (JoinedG g))
    
    --output and input sides of channel:
    data Messages a  -- NOT EXPORTED
    data Mailbox a
    
    instance Sources (Mailbox a) where
        type Joined (Mailbox a) = a
        newJoinedChan = undefined
    
    instance (Sources a, Sources b)=> Sources (a,b) where
        type Joined (a,b) = (Joined a, Joined b)
        newJoinedChan = undefined
    
    instance (SourcesG a, SourcesG b) => SourcesG (a :*: b) where
        type JoinedG (a :*: b) = (JoinedG a, JoinedG b)
        newJoinedChanG = undefined
    
    instance (SourcesG a, Datatype c) => SourcesG (M1 D c a) where
        type JoinedG (M1 D c a) = JoinedG a
        newJoinedChanG = fmap (first M1) newJoinedChanG
    
    instance (SourcesG a, Constructor c) => SourcesG (M1 C c a) where
        type JoinedG (M1 C c a) = JoinedG a
        newJoinedChanG = fmap (first M1) newJoinedChanG
    
    instance (SourcesG a, Selector c) => SourcesG (M1 S c a) where
        type JoinedG (M1 S c a) = JoinedG a
        newJoinedChanG = fmap (first M1) newJoinedChanG
    
    instance Sources s => SourcesG (K1 i s) where
        type JoinedG (K1 i s) = Joined s
        newJoinedChanG = fmap (first K1) newJoinedChan
    
    newtype Behavior a = Behavior (a -> IO (Behavior a))
    
    runBehaviorOn :: Behavior a -> Messages a -> IO ()
    runBehaviorOn = undefined
    
    spawn :: (Sources s) => Behavior (Joined s) -> IO s
    spawn = undefined
    
    data Pair a b = Pair a b deriving (Generic)
    
    instance (Sources a, Sources b) => Sources (Pair a b) where
        type Joined (Pair a b) = JoinedG (Rep (Pair a b))
    

    10-07 19:47