5

我有两个不重叠的类型集，并且想要制作另外一组是这两者的联合。代码示例：

class A a
class B b
class AB ab

instance A a => AB a
instance B b => AB b

GHC 6.12.3 不允许使用错误消息声明这一点：

    重复的实例声明：
      实例 (A a) => AB a -- 在 playground.hs:8:9-19 中定义
      实例 (B b) => AB b -- 在 playground.hs:9:9-19 中定义

我明白，这个声明导致失去对重叠实例的控制，因为AB a实例可能会在以后出现（我看不到处理这种情况的简单方法）。 我想应该有一些“解决方法”来获得相同的行为。A aB b

PS变体如：

newtype A a => WrapA a = WrapA a
newtype B b => WrapB b = WrapB b

instance A a => AB (WrapA a)
instance B b => AB (WrapB b)

和

data WrapAB a b = A a => WrapA a
                | B b => WrapB b

instance AB (WrapAB a b)

以及包含某些此类类型的任何其他类型都不适合我的需要（选择由第三方声明的类型的实现）

对@camccann 的评论：添加标志以控制标志上的合并/选择类型是个好主意，但我想避免诸如重叠实例的竞争之类的事情。对于那些对此答案感兴趣的人，压缩变体：

data Yes
data No

class IsA a flag | a -> flag
class IsB b flag | b -> flag

instance Delay No flag => IsA a flag
instance Delay No flag  => IsB b flag

instance (IsA ab isA, IsB ab isB, AB' isA isB ab) => AB ab

class AB' isA isB ab
instance (A a) => AB' Yes No a
instance (B b) => AB' No Yes b
instance (A a) => AB' Yes Yes a

class Delay a b | a -> b
instance Delay a a

instance IsA Bool Yes
instance A Bool
4

1 回答 1

3

As far as I know there's no "nice" way to accomplish this. You're stuck with adding cruft somewhere. Since you don't want wrapper types, the other option I can think of is messing with the class definitions instead, which means we're off to type-metaprogramming-land.

Now, the reason why this approach won't be "nice" is that class constraints are basically irrevocable. Once GHC sees the constraint, it's sticking with it, and if it can't satisfy the constraint compilation fails. This is fine for an "intersection" of class instances, but not helpful for a "union".

To get around this, we need type predicates with type-level booleans, rather than direct class constraints. In order to do that, we use multi-parameter type classes with functional dependencies to create type functions and overlapping instances with delayed unification to write "default instances".

First, we need some fun language pragmas:

{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UndecidableInstances #-}

Define some type-level booleans:

data Yes = Yes deriving Show
data No = No deriving Show

class TypeBool b where bval :: b
instance TypeBool Yes where bval = Yes
instance TypeBool No where bval = No

The TypeBool class isn't strictly necessary--I mostly use it to avoid working with undefined.

Next, we write membership predicates for the type classes we want to take the union of, with default instances to serve as the fall-through case:

class (TypeBool flag) => IsA a flag | a -> flag
class (TypeBool flag) => IsB b flag | b -> flag 

instance (TypeBool flag, TypeCast flag No) => IsA a flag
instance (TypeBool flag, TypeCast flag No) => IsB b flag

The TypeCast constraint is of course Oleg's infamous type unification class. The code for it can be found at the end of this answer. It's necessary here to delay picking the result type--the fundep says that the first parameter determines the second, and the default instances are fully generic, so putting No directly in the instance head would be interpreted as the predicate always evaluating to false, which isn't helpful. Using TypeCast instead waits until after GHC picks the most specific overlapped instance, which forces the result to be No when, and only when, no more specific instance can be found.

I'm going to make another not strictly necessary adjustment to the type classes themselves:

class (IsA a Yes) => A a where
    fA :: a -> Bool
    gA :: a -> Int

class (IsB b Yes) => B b where
    fB :: b -> Bool
    gB :: b -> b -> String

The class context constraint ensures that, if we write an instance for a class without also writing the matching predicate instance, we'll get a cryptic error immediately rather than very confusing bugs later. I've also added a few functions to the classes for demonstration purposes.

Next, the union class gets split into two pieces. The first has a single universal instance that just applies the membership predicates and invokes the second, which maps predicate results to the actual instances.

class AB ab where 
    fAB :: ab -> Bool
instance (IsA ab isA, IsB ab isB, AB' isA isB ab) => AB ab where
    fAB = fAB' (bval :: isA) (bval :: isB)

class AB' isA isB ab where fAB' :: isA -> isB -> ab -> Bool
instance (A a) => AB' Yes No a where fAB' Yes No = fA
instance (B b) => AB' No Yes b where fAB' No Yes = fB
instance (A ab) => AB' Yes Yes ab where fAB' Yes Yes = fA
-- instance (B ab) => AB' Yes Yes ab where fAB' Yes Yes = fB

Note that, if both predicates are true, we're explicitly choosing the A instance. The commented out instance does the same, but uses B instead. You could also remove both, in which case you'd get the exclusive disjunction of the two classes. The bval here is where I'm using the TypeBool class. Note also the type signatures to get the correct type boolean--this requires ScopedTypeVariables, which we enabled above.

To wrap things up, some instances to try out:

instance IsA Int Yes
instance A Int where
    fA = (> 0)
    gA = (+ 1)

instance IsB String Yes
instance B String where
    fB = not . null
    gB = (++)

instance IsA Bool Yes
instance A Bool where
    fA = id
    gA = fromEnum

instance IsB Bool Yes
instance B Bool where
    fB = not
    gB x y = show (x && y)

Trying it out in GHCi:

> fAB True
True
> fAB ""
False
> fAB (5 :: Int)
True
> fAB ()
No instance for (AB' No No ())
  . . .

And here's the TypeCast code, courtesy of Oleg.

class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b
class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b
class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b
instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x
instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''
instance TypeCast'' () a a where typeCast'' _ x  = x
于 2010-07-17T17:00:17.307 回答