{-# LANGUAGE TypeOperators, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE Safe #-}
{-| Description : Deriving strategies for making 'GHC.Generics.Generic'-based 'Binary' instances more expressive.
This module defines some types to be used with @DerivingVia@ when deriving 'Binary' instances.
-}
module Data.Binary.DerivingVia
( Alternatively(..)
) where
import Control.Applicative
import Data.Binary
import GHC.Generics
-- | Try to deserialize each constructor of @a@ in order.
--
-- For sum types, stock 'Binary' writes (and expects to read) an integer denoting the index of the constructor.
-- This isn't always what's needed. In the following example, the constructor is uniquely identified by the marker byte,
-- and its index in the Haskell ADT is irrelevant:
--
-- > data JfifSegment
-- > = App0Segment (MatchByte "app0 segment" 0xe0, JfifApp0)
-- > | DqtSegment (MatchByte "dqt segment" 0xdb, QuantTable)
-- > | SofSegment (MatchByte "sof segment" 0xc0, SofInfo)
-- > | DhtSegment (MatchByte "dht segment" 0xc4, HuffmanTable)
-- > | DriSegment (MatchByte "dri segment" 0xdd, RestartInterval)
-- > | SosSegment (MatchByte "sos segment" 0xda, SosImage)
-- > | UnknownSegment RawSegment
-- > deriving Generic
-- > deriving Binary via Alternatively JfifSegment
newtype Alternatively a = Alternatively { getAlt :: a }
class GAltBinary grecord where
gAltGet :: Get (grecord p)
gAltPut :: grecord p -> Put
instance Binary grecord => GAltBinary (K1 i grecord) where
gAltGet = K1 <$> get
gAltPut = put . unK1
instance GAltBinary grecord => GAltBinary (M1 i t grecord) where
gAltGet = M1 <$> gAltGet
gAltPut = gAltPut . unM1
instance (GAltBinary l, GAltBinary r) => GAltBinary (l :*: r) where
gAltGet = (:*:) <$> gAltGet <*> gAltGet
gAltPut (l :*: r) = gAltPut l <> gAltPut r
instance (GAltBinary l, GAltBinary r) => GAltBinary (l :+: r) where
gAltGet = L1 <$> gAltGet
<|> R1 <$> gAltGet
gAltPut (L1 l) = gAltPut l
gAltPut (R1 r) = gAltPut r
instance (Generic a, GAltBinary (Rep a)) => Binary (Alternatively a) where
get = Alternatively . to <$> gAltGet
put = gAltPut . from . getAlt