How to write generic instance (-s) to avoid large manual coding?-CodePudding

I have something like this:

data MsgDir = InMD | OutMD

data Msg
  = ResourcesM
  | TagsM
  deriving (Enum, Eq, Show)

data MsgPkt (msg::Msg) (msgDir::MsgDir) where
  GetResourcesMP :: MsgPkt 'ResourcesM 'OutMD
  MyResourcesMP :: Int -> Int -> String -> MsgPkt 'ResourcesM 'InMD

  GetTagsMP :: MsgPkt 'TagsM 'OutMD
  MyTagsMP :: [String] -> MsgPkt 'TagsM 'InMD

class MsgId (msg::Msg) (msgDir::MsgDir) where msgId :: Word8

instance MsgId 'ResourcesM 'OutMD where msgId = fromIntegral $ fromEnum ResourcesM
instance MsgId 'TagsM 'OutMD where msgId = fromIntegral $ fromEnum TagsM

and I wrote a couple of instances for 'TagsM (for 'OutMD, 'InMD):

instance forall m d. (m ~ 'TagsM, d ~ 'OutMD) => MessagePack (MsgPkt 'TagsM 'OutMD) where
  toObject GetTagsMP = toObject (msgId @m @d)
  fromObject o = do
    msg::Word8 <- fromObject o
    when (msg /= msgId @m @d) (fail $ "Unexpected MESSAGE: " <> show msg)
    pure GetTagsMP


instance forall m d. (m ~ 'TagsM, d ~ 'InMD) => MessagePack (MsgPkt 'TagsM 'InMD) where
  toObject (MyTagsMP a) = toObject (msgId @m @d, a)
  fromObject o = do
    (msg::Word8, a) <- fromObject o
    when (msg /= msgId @m @d) (fail $ "Unexpected MESSAGE: " <> show msg)
    pure $ MyTagsMP a

and before to write the same couple of instances for 'ResourcesM I was thinking - is it possible to reduce manual work - maybe with some generic? Actually I have more than TagsM, ResourcesM, so the manual coding will be very tedious. These constructors (like GetResourcesMP, MyResourcesMP) can have different number of arguments (and different types of arguments). I am not sure even that it's possible to simplify it with generics (or something similar).

How to write such a generic instance, so to use a simple and "automatic" / "semi-automatic" was to derive all these instances of the MessagePack ?

CodePudding user response：

One way would be to make a class for the unique part, and implement the shared part in terms of it. The downside of this approach is that it requires you to have control of the message pack object format; if you need to be compatible with some other tool, this way won't work.

class Packable a where
    type Packed a
    pack :: a -> Packed a
    unpack :: Packed a -> a

instance Packable (MsgPkt 'TagsM 'OutMD) where
    type Packed (MsgPkt 'TagsM 'OutMD) = ()
    pack _ = ()
    unpack _ = GetTagsMP

instance Packable (MsgPkt 'TagsM 'InMD) where
    type Packed (MsgPkt 'TagsM 'InMD) = [String]
    pack (MyTagsMP ss) = ss
    unpack = MyTagsMP

instance (Packable (MsgPkt m d), MessagePack (Packed (MsgPkt m d)))
    => MessagePack (MsgPkt m d) where
    toObject mp = toObject (msgId @m @d, pack mp)
    fromObject o = do
        (msg, packed) <- fromObject o
        when (msg /= msgId @m @d) (fail $ "Unexpected MESSAGE: " <> show msg)
        pure (unpack packed)