Merging/union two classes into one in Haskell

I have two non-overlapping sets of types and want to make other set which is union of these two. Code sample:

class A a
class B b
class AB ab

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

GHC 6.12.3 doesn't allow to declare this with error message:

    Duplicate instance declarations:
      instance (A a) => AB a -- Defined at playground.hs:8:9-19
      instance (B b) => AB b -- Defined at playground.hs:9:9-19

I understand, that this declaration leads to loosing control over overlapping instances of AB a because instances for A a and B b may arise later (and I can't see easy way to handle that).

I guess there should be some "work-around" to get the same behaviour.

P.S. Variants like:

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)

and

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

instance AB (WrapAB a b)

and any other which wraps some of this types doesn't suit my needs (choosing implementation by third-party-declared class of type)

Comment to @camccann: That's great idea to add flag to control merging/selecting type on flag, but I would like to avoid such things like 开发者_如何学Craces of overlapped instances. For thos who interested in this answer, compressed variant:

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

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