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
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]))