如何区分不同幻像类型的GADT构造函数？

Question

我正在开发一个系统（受 lsp-types 启发），该系统使用带有类型信息标记的 GADT 来表示客户端和服务器交换的不同类型的消息：

{-# LANGUAGE GADTs, DataKinds, KindSignatures, RankNTypes #-}

data From = FromClient | FromServer
data MessageType = Request | Notification

data Message (from :: From) (typ :: MessageType) where
  Request1 :: Message FromClient Request
  Request2 :: Message FromClient Request
  Request3 :: Message FromServer Request
  Notification1 :: Message FromClient Notification

我的问题是，给定这些构造函数的列表（在存在的包装器中），我如何 select 它们中具有特定类型的子集？

data SomeMessage where
  SomeMessage :: forall f t. Message f t -> SomeMessage

allMessages = [SomeMessage Request1
              , SomeMessage Request2
              , SomeMessage Request3
              , SomeMessage Notification1]

-- Desired output: [SomeMessage Request1, SomeMessage Request2, SomeMessage Request3]
filterToRequests :: [SomeMessage] -> [SomeMessage]
filterToRequests allMessages = undefined 

-- Desired output: [SomeMessage Request1, SomeMessage Request2]
filterToClientRequests :: [SomeMessage] -> [SomeMessage]
filterToClientRequests allMessages = undefined

Answer 1

我的解决方案利用了这样一个事实，即 GADT 构造函数在模式匹配时公开其范围内的任何存在类型约束。诀窍是引入两种类型类 KnownSender 和 KnownType 允许将它们各自的种类变量转换为运行时值：

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

data From = FromClient | FromServer deriving (Eq)
data MessageType = Request | Notification deriving (Eq)

data Message (from :: From) (typ :: MessageType) where
  Request1 :: Message 'FromClient 'Request
  Request2 :: Message 'FromClient 'Request
  Request3 :: Message 'FromServer 'Request
  Notification1 :: Message 'FromClient 'Notification

data SomeMessage where
  SomeMessage :: forall f t. KnownTags f t => Message f t -> SomeMessage

class KnownSender (f :: From) where
  knownSenderVal :: From

instance KnownSender 'FromClient where
  knownSenderVal = FromClient
instance KnownSender 'FromServer where
  knownSenderVal = FromServer
    
class KnownType (t :: MessageType) where
  knownTypeVal :: MessageType

instance KnownType 'Request where
  knownTypeVal = Request
instance KnownType 'Notification where
  knownTypeVal = Notification

type KnownTags f t = (KnownSender f, KnownType t)

knownTags :: SomeMessage -> (From,MessageType)
knownTags (SomeMessage msg) = knownTags' msg -- Magic happens here!
  where
    -- This function may also be written at the top level should you need it.
    knownTags' :: forall f t . KnownTags f t => Message f t -> (From, MessageType)
    knownTags' _ = (knownSenderVal @f ,knownTypeVal @t)

allMessages = [SomeMessage Request1
              , SomeMessage Request2
              , SomeMessage Request3
              , SomeMessage Notification1]

-- Desired output: [SomeMessage Request1, SomeMessage Request2, SomeMessage Request3]
filterToRequests :: [SomeMessage] -> [SomeMessage]
filterToRequests = filter ((== Request) . snd . knownTags)
-- Desired output: [SomeMessage Request1, SomeMessage Request2]
filterToClientRequests :: [SomeMessage] -> [SomeMessage]
filterToClientRequests = filter ((== FromClient) . fst . knownTags)

请注意，您的 SomeMessage 类型必须稍微修改以在其构造函数中包含 KnownTags 约束。还添加了 From 和 MessageType 的 Eq 个实例。

更新：

根据您的评论，如果您需要 [SomeMessage] -> [SomeRequestMessage] 函数，一种方法是使用反射：

{-# LANGUAGE FlexibleContexts #-}

import Type.Reflection (TypeRep,Typeable,typeRep,eqTypeRep)
import Data.Type.Equality
import Data.Maybe (maybeToList)

-- Add Typeable constraints for f and t
type KnownTags f t = (Typeable f,KnownSender f, Typeable t, KnownType t)

-- General utility function useful for dynamic programming and reflection
withKnownMsg :: forall a . SomeMessage -> (forall f t . KnownTags f t => Message f t -> a) -> a
withKnownMsg (SomeMessage msg) f = f msg

data SomeRequestMessage where
  SomeRequestMessage :: forall f. KnownTags f 'Request => Message f 'Request -> SomeRequestMessage

toSomeRequest :: SomeMessage -> Maybe SomeRequestMessage
toSomeRequest someMsg = withKnownMsg someMsg f
  where
    f :: forall f t . (KnownTags f t) => Message f t -> Maybe SomeRequestMessage
    f msg = fmap (\HRefl -> SomeRequestMessage msg). eqTypeRep (typeRep @t) $ typeRep @'Request

someRequestMsgs :: [SomeMessage] -> [SomeRequestMessage]
someRequestMsgs msgs = msgs >>= (maybeToList . toSomeRequest)

Answer 2

您应该可以使用 Data.Typeable 中的 cast 来完成此操作。特别是，如果您有：

data SomeMessage where
  SomeMessage :: forall f t. (Typeable f, Typeable t) => Message f t -> SomeMessage

data SomeMessageRequest where
  SomeMessageRequest :: forall f. Message f Request -> SomeMessageRequest

（注意SomeMessage中的Typeable字典），可以使用作用域类型变量和类型应用来写：

maybeRequest :: SomeMessage -> Maybe SomeMessageRequest
maybeRequest (SomeMessage (msg :: Message f t))
  = SomeMessageRequest <$> cast @_ @(Message f Request) msg

获得：

allRequests :: [SomeMessageRequest]
allRequests = catMaybes $ map maybeRequest allMessages

完整代码：

{-# LANGUAGE GADTs, DataKinds, KindSignatures, RankNTypes, ScopedTypeVariables, TypeApplications #-}

import Data.Typeable
import Data.Maybe

data From = FromClient | FromServer
data MessageType = Request | Notification

data Message (from :: From) (typ :: MessageType) where
  Request1 :: Message FromClient Request
  Request2 :: Message FromClient Request
  Request3 :: Message FromServer Request
  Notification1 :: Message FromClient Notification

data SomeMessage where
  SomeMessage :: forall f t. (Typeable f, Typeable t) => Message f t -> SomeMessage

data SomeMessageRequest where
  SomeMessageRequest :: forall f. Message f Request -> SomeMessageRequest

allMessages = [ SomeMessage Request1
              , SomeMessage Request2
              , SomeMessage Request3
              , SomeMessage Notification1]

maybeRequest :: SomeMessage -> Maybe SomeMessageRequest
maybeRequest (SomeMessage (msg :: Message f t))
  = SomeMessageRequest <$> cast @_ @(Message f Request) msg

allRequests :: [SomeMessageRequest]
allRequests = catMaybes $ map maybeRequest allMessages

如何区分不同幻像类型的GADT构造函数？

How to differentiate GADT constructors with different phantom types?

haskell

gadt