Decode list to generic data with 4 selectors

Question

I'm trying to generically derive instances for a decoder that uses lists. When I use derive (Generic) on a type with multiple selectors, the selectors are associated into a tree structure, which for example for four constructors looks like ((S1 a :*: S1 b) :*: (S1 c :*: S1 d)). I can't figure out how to write the instances for this, even though I've figured out the algorithm how the selectors are associated.

Minimal example:

{-# language DefaultSignatures, DeriveGeneric #-}
import Data.List
import GHC.Generics
import Numeric.Natural

data Foo = Foo Int Int Int Int
    deriving (Generic, Show)

data Bar = Bar Int Int
    deriving (Generic, Show)

class Codec a where
    encode :: a -> [Int]
    default encode :: (Generic a, Codec' (Rep a)) => a -> [Int]
    encode = encode' . from
    decode :: [Int] -> a
    default decode :: (Generic a, Codec' (Rep a)) => [Int] -> a
    decode = to . decode'

class Codec' f where
    encode' :: f a -> [Int]
    decode' :: [Int] -> f a

instance Codec Int where
    encode = singleton
    decode = head

instance Codec c => Codec' (K1 i c) where
    encode' (K1 x) = encode x
    decode' x = K1 (decode x)

instance Codec' f => Codec' (M1 i t f) where
    encode' (M1 x) = encode' x
    decode' x = M1 (decode' x)

instance (Codec' f, Codec' g) => Codec' (f :*: g) where
    encode' (x :*: y) = encode' x <> encode' y
    decode' (x:xs) = decode' (singleton x) :*: decode' xs

instance Codec Foo
instance Codec Bar

main :: IO ()
main = do
    print (decode $ encode (Bar 1 2) :: Bar)
    print (decode $ encode (Foo 1 2 3 4) :: Foo)

Output:

Bar 1 2
Foo 1 generic.hs: Prelude.head: empty list
CallStack (from HasCallStack):
  error, called at libraries/base/GHC/List.hs:1644:3 in base:GHC.List
  errorEmptyList, called at libraries/base/GHC/List.hs:87:11 in base:GHC.List
  badHead, called at libraries/base/GHC/List.hs:83:28 in base:GHC.List
  head, called at /private/tmp/generic.hs:26:14 in main:Main

Expected output:

Bar 1 2
Foo 1 2 3 4

Answer 1

The solution proposed in the comments will probably work, but if you'd like something less hacky, you want to reimplement your decode/decode' pair so that they operate more like parsers on an [Int] input stream, returning the "unused" portion of the stream when they've finished their work. That is, your generic class ought to look something like:

class Codec' f where
    encode' :: f a -> [Int]
    decode' :: [Int] -> (f a, [Int])

and this lets you write:

instance (Codec' f, Codec' g) => Codec' (f :*: g) where
    encode' (x :*: y) = encode' x <> encode' y
    decode' xs = let (f, xs') = decode' xs
                     (g, xs'') = decode' xs'
                 in  (f :*: g, xs'')

where the first sub-decode' can determine how much of the input stream to absorb before invoking the second sub-decode' on the remainder.

The fully rewritten example:

{-# LANGUAGE DefaultSignatures, DeriveGeneric #-}

import Data.List
import GHC.Generics
import Numeric.Natural
import Control.Arrow

data Foo = Foo Int Int Int Int
    deriving (Generic, Show)

data Bar = Bar Int Int
    deriving (Generic, Show)

class Codec a where
    encode :: a -> [Int]
    default encode :: (Generic a, Codec' (Rep a)) => a -> [Int]
    encode = encode' . from
    decode :: [Int] -> (a, [Int])
    default decode :: (Generic a, Codec' (Rep a)) => [Int] -> (a, [Int])
    decode = first to . decode'

class Codec' f where
    encode' :: f a -> [Int]
    decode' :: [Int] -> (f a, [Int])

instance Codec Int where
    encode = singleton
    decode (x:xs) = (x, xs)

instance Codec c => Codec' (K1 i c) where
    encode' (K1 x) = encode x
    decode' x = first K1 (decode x)

instance Codec' f => Codec' (M1 i t f) where
    encode' (M1 x) = encode' x
    decode' x = first M1 (decode' x)

instance (Codec' f, Codec' g) => Codec' (f :*: g) where
    encode' (x :*: y) = encode' x <> encode' y
    decode' xs = let (f, xs') = decode' xs
                     (g, xs'') = decode' xs'
                 in  (f :*: g, xs'')

instance Codec Foo
instance Codec Bar

main :: IO ()
main = do
    print (decode $ encode (Bar 1 2) :: (Bar, [Int]))
    print (decode $ encode (Foo 1 2 3 4) :: (Foo, [Int]))