How to derive instances for records with type-families

Question

Here's what I'm trying but it doesn't compile:

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.Text as T
import Data.Int (Int64)

type family Incoming validationResult baseType
type instance Incoming Validated baseType = baseType
type instance Incoming ValidationErrors baseType = Either [T.Text] baseType

data Validated
data ValidationErrors

data Tag = Tag {unTag :: T.Text} deriving (Eq, Show)

data NewTag f = NewTag
  {
    ntClientId :: Incoming f Int64
  , ntTag :: Incoming f Tag
  }

deriving instance (Show baseType) => Show (Incoming Validated baseType)
deriving instance (Show baseType) => Show (Incoming ValidationErrors baseType)

Compilation errors:

23  38 error           error:
 • Illegal type synonym family application in instance:
     Incoming Validated baseType
 • In the stand-alone deriving instance for
     ‘(Show baseType) => Show (Incoming Validated baseType)’ (intero)
24  38 error           error:
 • Illegal type synonym family application in instance:
     Incoming ValidationErrors baseType
 • In the stand-alone deriving instance for
     ‘(Show baseType) => Show (Incoming ValidationErrors baseType)’ (intero)

Answer 1

You have two problems here. The first one is what GHC is telling you. Basically, you can't have an instance that depends on a type family (the type family can be there, but only if all the arguments it gets are concrete types). All sorts of bad things can start happening once you allow this, not the least of which is that the right hand side of your type family could have calls to other type families.

Generally, one can solve this sort of problem by moving the type family application to a constraint:

deriving instance (Show baseType, i ~ Incoming Validated baseType) => Show i
deriving instance (Show baseType, i ~ Incoming ValidationErrors baseType) => Show i

Doing this actually makes the second problem obvious: your instance heads are too general.

That said, I'm not sure there is even anything to fix - just get rid of the deriving lines. You would like the first one to boil down to saying: derive an instance of Show basetype given the Show basetype constraint (which is completely pointless). The second one is equally pointless - Either already has an instance of Show.

Answer 2

This can't be made to work. Here's the problem:

Incoming Validated        (Either [T.Text] Int) ~ Either [T.Text] Int
Incoming ValidationErrors Int                   ~ Either [T.Text] Int

Now, if you want a Show (Either [T.Text] Int), you have three options:

instance (Show a, Show b) => Show (Either a b) -- from Prelude
instance Show baseType    => Show (Incoming Validated baseType)
instance Show baseType    => Show (Incoming ValidationErrors baseType)

Any of these would be a valid instance, and GHC requires global uniqueness of instances. Indeed, the problem is that type families aren't injective, and so just because you know that you need an instance TyCls A, GHC can't generate the application TyFam B1 B2 B3 that would produce an A – such an application might not even be unique!

---

There are a couple ways you could fix this.

1. Do you really need the Show instance? Maybe all that you need is a Show constraint on the functions that want to use it. So for example:

   {-# LANGUAGE FlexibleContexts, UndecidableInstances #-}
   -- But not FlexibleInstances
   
   deriving instance (Show (Incoming f Int64), Show (Incoming f Tag))
     => Show (NewTag f)
   

   GHC will propagate those constraints everywhere, but they'll always be satisfiable by the end user. And if f is ever a concrete type, they'll vanish entirely!

2. Do you really want Incoming things to be indistinguishable from base types? If not, you could use a GADT here:

   {-# LANGUAGE GADTs, FlexibleInstances #-}
   
   -- ...
   
   data Incoming :: * -> * -> * where
     IncomingValidated        :: baseType
                              -> Incoming Validated baseType
     IncomingValidationErrors :: Either [T.Text] baseType
                              -> Incoming ValidationErrors baseType
   
   -- ...
   
   deriving instance Show (NewTag Validated)
   deriving instance Show (NewTag ValidationErrors)
   

The downside here is twofold: first, you have to pattern-match everywhere you use these; second, you can't (on GHC 7.10, at least) use StandaloneDeriving for the GADT Show instances, you need to write them by hand:

    -- deriving instance Show baseType => Show (Incoming Validated baseType)
    instance Show baseType => Show (Incoming Validated baseType) where
      show (IncomingValidated bt) = "IncomingValidated " ++ show bt

    -- deriving instance Show baseType => Show (Incoming ValidationErrors baseType)
    instance Show baseType => Show (Incoming ValidationErrors baseType) where
      show (IncomingValidationErrors e) = "IncomingValidationErrors " ++ show e

Either of these could be a good solution; option (1) is the smallest change from what you're already doing, and so would likely be where I would step first.

---

One other note: in modern (7.10+) GHCs, we can clean up something in your code. Right now, you have two places your code allows too much flexibility.

1. You can consider a value of the type NewTag Bool, or NewTag (), or ….
2. The Incoming type family is open – anybody could add a type instance Incoming Bool baseType = Maybe baseType, or Incoming () () = Int, or ….

You only want to consider Validated or ValidationErrors there, and you've already written all the possible type family instances! GHC provides two features for improving this: DataKinds and closed type families. With closed type families, you can write

type family Incoming validationResult baseType where
  Incoming Validated        baseType = baseType
  Incoming ValidationErrors baseType = Either [T.Text] baseType

Now, this is closed – nobody else can ever add a new case. This solves #2.

As for #1, if we turn on DataKinds, GHC automatically promotes our value constructors to the type level! So just as we have that Int :: *, we have that 'False :: Bool – the ' indicates to GHC that we're on the type level. Adding this feature looks as follows:

{-# LANGUAGE DataKinds #-}

-- ...

data ValidationResult = Validated | ValidationErrors
                      deriving (Eq, Ord, Enum, Bounded, Show, Read)

---- EITHER:
---- Option (1), with a type family
-- The only change here is to add tick marks!
type family Incoming validationResult baseType where
  Incoming 'Validated        baseType = baseType
  Incoming 'ValidationErrors baseType = Either [T.Text] baseType

---- OR:
---- Option (2), with a GADT
-- Here, we change the kind signature and add tick marks
data Incoming :: ValidationResult -> * -> * where
    IncomingValidated        :: baseType
                             -> Incoming 'Validated baseType
    IncomingValidationErrors :: Either [T.Text] baseType
                             -> Incoming 'ValidationErrors baseType

We can also add kind signatures if we want – type family Incoming (validationResult :: ValidationResult) (baseType :: *) :: * where … or data NewTag (f :: ValidationResult) = …, but those will be inferred, and are consequently optional.

If the tick really irritates you, you can use the following trick, which I picked up from the GHC source code:

type Validated        = 'Validated
type ValidationErrors = 'ValidationErrors

---

OK, one more type-level fun thing, because I can't resist :-) Let's consider option (1) again, with the type family. We have to provide this annoying (Show (Incoming f Int64), Show (Incoming f Tag)) constraint everywhere, which is kinda bulky, especially if we want to abstract over it – to produce an Eq instance, it's the same, but with Eq instead of Show. And what if there are more fields?

If we turn on ConstraintKinds, we can abstract over constraints. That works like so:

{-# LANGUAGE ConstraintKinds #-}

import GHC.Exts (Constraint)

type NewTagFieldsAre (c :: * -> Constraint) f =
  (c (Incoming f Int64), c (Incoming f Tag))

(We need the kind signature so GHC doesn't think this produces an ordinary tuple.) Then we can specify

deriving instance NewTagFieldsAre Eq   f => Eq   (NewTag f)
deriving instance NewTagFieldsAre Ord  f => Ord  (NewTag f)
deriving instance NewTagFieldsAre Show f => Show (NewTag f)
deriving instance NewTagFieldsAre Read f => Read (NewTag f)

And everything is much shorter!

---

Putting this all together, here's what option (1) looks like, with the type family. The only thing that's different about this is that I consolidated the changes I made, reformatted things slightly, and made a few other taste-based changes.

{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies,
             ConstraintKinds, DataKinds, StandaloneDeriving #-}

import Data.Text as T
import Data.Int (Int64)
import GHC.Exts (Constraint)

data Tag = Tag { unTag :: T.Text } deriving (Eq, Ord, Show, Read)

data ValidationResult = Validated | ValidationErrors
                      deriving (Eq, Ord, Enum, Bounded, Show, Read)

type family Incoming (vres :: ValidationResult) (base :: *) :: * where
  Incoming 'Validated        base = base
  Incoming 'ValidationErrors base = Either [T.Text] base

data NewTag f = NewTag { ntClientId :: Incoming f Int64
                       , ntTag      :: Incoming f Tag }

type NewTagFieldsAre (c :: * -> Constraint) f =
  (c (Incoming f Int64), c (Incoming f Tag))

deriving instance NewTagFieldsAre Eq   f => Eq   (NewTag f)
deriving instance NewTagFieldsAre Ord  f => Ord  (NewTag f)
deriving instance NewTagFieldsAre Show f => Show (NewTag f)
deriving instance NewTagFieldsAre Read f => Read (NewTag f)

And for completeness, the GADT option:

{-# LANGUAGE GADTs, FlexibleInstances, TypeFamilies, DataKinds,
             StandaloneDeriving #-}

import Data.Text as T
import Data.Int (Int64)

data Tag = Tag { unTag :: T.Text } deriving (Eq, Ord, Show, Read)

data ValidationResult = Validated | ValidationErrors
                      deriving (Eq, Ord, Enum, Bounded, Show, Read)

data Incoming :: ValidationResult -> * -> * where
  IncomingValidated        :: base
                           -> Incoming Validated base
  IncomingValidationErrors :: Either [T.Text] base
                           -> Incoming ValidationErrors base

instance Eq base => Eq (Incoming Validated base) where
  IncomingValidated x == IncomingValidated y = x == y

instance Eq base => Eq (Incoming ValidationErrors base) where
  IncomingValidationErrors ex == IncomingValidationErrors ey = ex == ey

instance Ord base => Ord (Incoming Validated base) where
  IncomingValidated x `compare` IncomingValidated y = x `compare` y

instance Ord base => Ord (Incoming ValidationErrors base) where
  IncomingValidationErrors ex `compare` IncomingValidationErrors ey = ex `compare` ey

instance Show base => Show (Incoming Validated base) where
  show (IncomingValidated x) = "IncomingValidated " ++ show x

instance Show base => Show (Incoming ValidationErrors base) where
  show (IncomingValidationErrors ex) = "IncomingValidationErrors " ++ show ex

-- `Show` properly handling precedence, along with the `Read` instance, are left
-- as an exercise for the interested reader.

data NewTag f = NewTag { ntClientId :: Incoming f Int64
                       , ntTag      :: Incoming f Tag }

deriving instance Eq   (NewTag Validated)
deriving instance Eq   (NewTag ValidationErrors)
deriving instance Ord  (NewTag Validated)
deriving instance Ord  (NewTag ValidationErrors)
deriving instance Show (NewTag Validated)
deriving instance Show (NewTag ValidationErrors)

That need to hand-derive the instances is really dragging it down!