Question

说我有以下内容：

data Type
  = StringType
  | IntType
  | FloatType

data Op
  = Add Type
  | Subtract Type

我想限制Subtract下的可能类型，以使其仅允许int或float。换句话说，

patternMatch :: Op -> ()
patternMatch (Add StringType) = ()
patternMatch (Add IntType) = ()
patternMatch (Add FloatType) = ()
patternMatch (Subtract IntType) = ()
patternMatch (Subtract FloatType) = ()

应该是详尽的模式匹配。

执行此操作的一种方法是为每个操作引入单独的数据类型，其中每个操作仅具有允许的子类型：

newtype StringType = StringType
newtype IntType = IntType
newtype FloatType = FloatType

data Addable = AddableString StringType | AddableInt IntType | AddableFloat FloatType

data Subtractable = SubtractableInt IntType | SubtractableFloat FloatType

data Op = Add Addable | Subtract Subtractable

但是，这使事情变得更加冗长，因为我们必须为每个类别创建一个新的构造函数名称。有没有一种方法可以“限制”类型中可能的构造函数而无需创建显式子集？使用DataKinds会更短吗？除了只是为每个约束指定新数据之外，我不确定如何使其更加简洁。

这个问题是我的original question的扩展，我在那儿询问了数据类型联合。那里有很多好的建议，但是不幸的是，模式匹配时，联合不起作用。编译器仍然会抱怨这些模式并不详尽。

Answer 1

此解决方案有效，但最终可能不太实用。我正在使用red-black-record包中的可扩展变体。

我们这样定义类型：

{-# LANGUAGE DeriveGeneric, DataKinds, TypeFamilies, TypeApplications #-}
import           GHC.Generics
import           Data.RBR

data Ty
  = StringTy ()
  | IntTy ()
  | FloatTy ()
  deriving (Show,Generic)
instance ToVariant Ty

type ShrunkTy = Variant I (Delete "StringTy" () (VariantCode Ty))

data Op
  = Add Ty
  | Subtract ShrunkTy

那些烦人的()参数可以克服limitation的红黑记录；当前没有ToVariant的求和类型实例，没有构造函数参数。

基本上，我们将使用VariantCode类型族从Delete中删除StringTy构造函数，并使用一组简化的构造函数定义一个Variant。

然后我们可以使用如下类型：

foo :: Op -> String
foo op = 
    case op of
        Add ty -> 
            show "add" ++ show ty
        Subtract ty -> 
            let cases = addCaseI @"IntTy"   show
                      . addCaseI @"FloatTy" show
                      $ unit
            in  show "add" ++ eliminateSubset cases ty

Variant是eliminated使用Record函数构造的处理程序addCaseI。 unit是空的Record。如果Record没有涵盖所有会导致类型错误（完全难以理解）的情况。

此解决方案的缺点是：

用于处理收缩类型的不同语法。
更糟糕的类型错误。
运行时速度较慢，不如本机求和类型有效。
可扩展记录库的常见祸根：very slow大型类型的编译时间。

其他可扩展的记录库（可能是vinyl + vinyl-generics）可能会提供更好的人机工程学。

Answer 2

使用DataKinds为GADT编制索引是一种可行的方法，具体取决于您的用例：

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

-- The “group” of a type
data TypeGroup = NonNumeric | Numeric

-- A type indexed by whether it’s numeric
data Type (g :: TypeGroup) where
  StringType :: Type 'NonNumeric
  IntType :: Type 'Numeric
  FloatType :: Type 'Numeric

data Op where
  Add :: Type a -> Op
  Subtract :: Type 'Numeric -> Op

请注意，Add可以在'Numeric或'NonNumeric Type上运行，因为类型变量（{已量化）a。

现在这将起作用：

patternMatch :: Op -> ()
patternMatch (Add StringType) = ()
patternMatch (Add IntType) = ()
patternMatch (Add FloatType) = ()
patternMatch (Subtract IntType) = ()
patternMatch (Subtract FloatType) = ()

但是添加它会失败：

patternMatch (Subtract StringType) = ()

警告有关无法访问的代码：Couldn't match type ‘'Numeric’ with ‘'NonNumeric’。

如果您需要添加更多类型分组，则可能更喜欢引入类型族来对类型进行分类，例如：

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}

-- An un-indexed type
data TypeTag = StringTag | IntTag | FloatTag

-- A type indexed with a tag we can dispatch on
data Type (t :: TypeTag) where
  StringType :: Type StringTag
  IntType :: Type IntTag
  FloatType :: Type FloatTag

-- Classify a type as numeric
type family IsNumeric' (t :: TypeTag) :: Bool where
  IsNumeric' 'StringTag = 'False
  IsNumeric' 'IntTag = 'True
  IsNumeric' 'FloatTag = 'True

-- A convenience synonym for the constraint
type IsNumeric t = (IsNumeric' t ~ 'True)

data Op where
  Add :: Type t -> Op
  Subtract :: IsNumeric t => Type t -> Op

如果添加冗余模式，这将产生（描述较少的）警告Couldn't match type ‘'True’ with ‘'False’。

使用GADT时，您经常需要存在和RankNTypes才能使用运行时信息；为此，这些模式可能会有用：

{-# LANGUAGE RankNTypes #-}

-- Hide the type-level tag of a type
data SomeType where
  SomeType :: Type t -> SomeType

-- An unknown type, but that is known to be numeric
data SomeNumericType where
  SomeNumericType :: IsNumeric t => Type t -> SomeNumericType

parseType :: String -> Maybe SomeType
parseType "String" = Just (SomeType StringType)
parseType "Int" = Just (SomeType IntType)
parseType "Float" = Just (SomeType FloatType)
parseType _ = Nothing

-- Unpack the hidden tag within a function
withSomeType :: SomeType -> (forall t. Type t -> r) -> r
withSomeType (SomeType t) k = k t

将模式匹配限制为构造函数的子集

2 个答案: