GHC Generics: How to write an implementation of (:+:) that converts sum types from/to integers?

问题

I would like to write an implementation of

instance (GMySerialize a, GMySerialize b) => GMySerialize (a :+: b)

Where GMySerialize is defined as:

class GMySerialize f where
    gtoMyS :: f a -> MySerialize
    gfromMyS :: MySerialize -> Maybe (f a)

That will, for any sum type consisting solely of nullary data constructors (such as data MyType = A | B | C | D | E | f), convert it to and from MySerializeInt, where MySerializeInt is a constructor for MySerialize that takes one int parameter.

I started out with

instance (GMySerialize a, GMySerialize b) => GMySerialize (a :+: b) where
   gtoMyS (L1 x) = MySerializeInt (0 + rest)
     where rest = case gtoMyS x of
             MySerializeInt n -> n
             MySerializeNil -> 0
             err -> error $ show err
   gtoMyS (R1 x) = MySerializeInt (1 + rest)
     where rest = case gtoMyS x of
             MySerializeInt n -> n
             MySerializeNil -> 0
             err -> error $ show err

But realised that's horribly wrong, and am not sure how to fix it. How is it wrong? As an example, the following produce the same integer, but they should not as they represent different constructors:

M1 {unM1 = L1 (R1 (M1 {unM1 = U1}))}
M1 {unM1 = R1 (L1 (M1 {unM1 = U1}))}

I'm also unsure how I'd go about writing the gfromMyS instances even if I got gtoMyS working.

To phrase it another way, what I'm looking to do has an equivalent effect to writing a Template Haskell function that generates:

instance MySerialize t where
  toMyS x = MySerializeInt (toEnum x)
  fromMyS (MySerializeInt n) -> Just (fromEnum n)
  fromMyS _ -> Nothing

For every single t where t is sum types with only nullary constructors that implement Enum.

回答1:

The trick is to make another class that counts the number of constructors

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

import Data.Functor ((<$>))
import Data.Tagged

import GHC.Generics

class GNumConstructors (f :: * -> *) where
    -- Is this close enough to CAF to get memoed in the dictionary?
    gnumConstructors :: Tagged f Int

instance GNumConstructors (M1 C c f) where
    gnumConstructors = Tagged 1

instance (GNumConstructors a, GNumConstructors b) => GNumConstructors (a :+: b) where
    gnumConstructors = Tagged $ unTagged (gnumConstructors :: Tagged a Int) +  unTagged (gnumConstructors :: Tagged b Int)  

Then you can easily divide up the integers between those on the left side (less than the number of possibilities on the left) and those on the right side (any larger numbers).

type MyS = Int

class GMySerialize f where
    gtoMyS :: f a -> MyS
    gfromMyS :: MyS -> Maybe (f a)

instance (GNumConstructors a, GMySerialize a, GMySerialize b) => GMySerialize (a :+: b) where
    gtoMyS (L1 l) = gtoMyS l
    gtoMyS (R1 r) = unTagged (gnumConstructors :: Tagged a Int) + gtoMyS r

    gfromMyS x = if x < unTagged (gnumConstructors :: Tagged a Int)
                 then L1 <$> gfromMyS x
                 else R1 <$> gfromMyS (x - unTagged (gnumConstructors :: Tagged a Int))

Any individual constructor is represented by 0 and we peek straight through metadata.

instance GMySerialize U1 where
    gtoMyS U1 = 0
    gfromMyS 0 = Just U1
    gfromMyS _ = Nothing

instance GMySerialize f => GMySerialize (M1 i c f) where
    gtoMyS (M1 a) = gtoMyS a
    gfromMyS ms = M1 <$> gfromMyS ms

Combined with a MySerialize class we can flesh out a complete example for MyType and test it

class MySerialize a where
    toMyS :: a -> MyS
    fromMyS :: MyS -> Maybe a

    default toMyS :: (Generic a, GMySerialize (Rep a)) => a -> MyS
    toMyS a = gtoMyS $ from a

    default fromMyS :: (Generic a, GMySerialize (Rep a)) => MyS -> Maybe a
    fromMyS a = to <$> gfromMyS a

data MyType = A | B | C | D | E | F
    deriving (Generic, Show)

instance MySerialize MyType

main = do
    print . map toMyS $ [A, B, C, D, E, F]
    print . map (fromMyS :: MyS -> Maybe MyType) $ [-1, 0, 1, 2, 3, 4, 5, 6]

A through F are mapped to the numbers 0 through 5. Reading in those numbers reproduces A through F. Trying to read in a number outside that range produces Nothing.

[0,1,2,3,4,5]
[Nothing,Just A,Just B,Just C,Just D,Just E,Just F,Nothing]

来源：https://stackoverflow.com/questions/32107706/ghc-generics-how-to-write-an-implementation-of-that-converts-sum-types-fr