{-# 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 { Alternatively a -> a
getAlt :: a }

class GAltBinary grecord where
  gAltGet :: Get (grecord p)
  gAltPut :: grecord p -> Put

instance Binary grecord => GAltBinary (K1 i grecord) where
  gAltGet :: Get (K1 i grecord p)
gAltGet = grecord -> K1 i grecord p
forall k i c (p :: k). c -> K1 i c p
K1 (grecord -> K1 i grecord p) -> Get grecord -> Get (K1 i grecord p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get grecord
forall t. Binary t => Get t
get
  gAltPut :: K1 i grecord p -> Put
gAltPut = grecord -> Put
forall t. Binary t => t -> Put
put (grecord -> Put)
-> (K1 i grecord p -> grecord) -> K1 i grecord p -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i grecord p -> grecord
forall i c k (p :: k). K1 i c p -> c
unK1

instance GAltBinary grecord => GAltBinary (M1 i t grecord) where
  gAltGet :: Get (M1 i t grecord p)
gAltGet = grecord p -> M1 i t grecord p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (grecord p -> M1 i t grecord p)
-> Get (grecord p) -> Get (M1 i t grecord p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (grecord p)
forall (grecord :: * -> *) p. GAltBinary grecord => Get (grecord p)
gAltGet
  gAltPut :: M1 i t grecord p -> Put
gAltPut = grecord p -> Put
forall (grecord :: * -> *) p.
GAltBinary grecord =>
grecord p -> Put
gAltPut (grecord p -> Put)
-> (M1 i t grecord p -> grecord p) -> M1 i t grecord p -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i t grecord p -> grecord p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GAltBinary l, GAltBinary r) => GAltBinary (l :*: r) where
  gAltGet :: Get ((:*:) l r p)
gAltGet = l p -> r p -> (:*:) l r p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (l p -> r p -> (:*:) l r p)
-> Get (l p) -> Get (r p -> (:*:) l r p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (l p)
forall (grecord :: * -> *) p. GAltBinary grecord => Get (grecord p)
gAltGet Get (r p -> (:*:) l r p) -> Get (r p) -> Get ((:*:) l r p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (r p)
forall (grecord :: * -> *) p. GAltBinary grecord => Get (grecord p)
gAltGet
  gAltPut :: (:*:) l r p -> Put
gAltPut (l p
l :*: r p
r) = l p -> Put
forall (grecord :: * -> *) p.
GAltBinary grecord =>
grecord p -> Put
gAltPut l p
l Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> r p -> Put
forall (grecord :: * -> *) p.
GAltBinary grecord =>
grecord p -> Put
gAltPut r p
r

instance (GAltBinary l, GAltBinary r) => GAltBinary (l :+: r) where
  gAltGet :: Get ((:+:) l r p)
gAltGet = l p -> (:+:) l r p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l p -> (:+:) l r p) -> Get (l p) -> Get ((:+:) l r p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (l p)
forall (grecord :: * -> *) p. GAltBinary grecord => Get (grecord p)
gAltGet
        Get ((:+:) l r p) -> Get ((:+:) l r p) -> Get ((:+:) l r p)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> r p -> (:+:) l r p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r p -> (:+:) l r p) -> Get (r p) -> Get ((:+:) l r p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (r p)
forall (grecord :: * -> *) p. GAltBinary grecord => Get (grecord p)
gAltGet
  gAltPut :: (:+:) l r p -> Put
gAltPut (L1 l p
l) = l p -> Put
forall (grecord :: * -> *) p.
GAltBinary grecord =>
grecord p -> Put
gAltPut l p
l
  gAltPut (R1 r p
r) = r p -> Put
forall (grecord :: * -> *) p.
GAltBinary grecord =>
grecord p -> Put
gAltPut r p
r

instance (Generic a, GAltBinary (Rep a)) => Binary (Alternatively a) where
  get :: Get (Alternatively a)
get = a -> Alternatively a
forall a. a -> Alternatively a
Alternatively (a -> Alternatively a)
-> (Rep a Any -> a) -> Rep a Any -> Alternatively a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> Alternatively a)
-> Get (Rep a Any) -> Get (Alternatively a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Rep a Any)
forall (grecord :: * -> *) p. GAltBinary grecord => Get (grecord p)
gAltGet
  put :: Alternatively a -> Put
put = Rep a Any -> Put
forall (grecord :: * -> *) p.
GAltBinary grecord =>
grecord p -> Put
gAltPut (Rep a Any -> Put)
-> (Alternatively a -> Rep a Any) -> Alternatively a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from (a -> Rep a Any)
-> (Alternatively a -> a) -> Alternatively a -> Rep a Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alternatively a -> a
forall a. Alternatively a -> a
getAlt