module Sqel.Codec.Product where

import Generics.SOP (
  All,
  I,
  K (K),
  NP,
  NS (Z),
  Projection,
  SOP (SOP),
  Top,
  hcmap,
  hcollapse,
  hsequence,
  hzipWith,
  projections,
  unI,
  unSOP,
  unZ,
  type  (-.->) (Fn),
  )
import Generics.SOP.GGP (gfrom, gto)
import Lens.Micro.Extras (view)

import qualified Sqel.Data.Codec as Codec
import Sqel.Data.Codec (Codec (Codec), Decoder, Encoder, FullCodec)
import Sqel.SOP.Constraint (ConstructProd, ReifyProd)

prodParams ::
  ∀ as b .
  Contravariant b =>
  (∀ x . Monoid (b x)) =>
  All Top as =>
  NP b as ->
  b (NP I as)
prodParams :: forall (as :: [*]) (b :: * -> *).
(Contravariant b, forall x. Monoid (b x), All Top as) =>
NP b as -> b (NP I as)
prodParams NP b as
np =
  forall a. Monoid a => [a] -> a
mconcat (forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse NP (K (b (NP I as))) as
qps)
  where
    qps :: NP (K (b (NP I as))) as
    qps :: NP (K (b (NP I as))) as
qps =
      forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hzipWith forall a. b a -> Projection I as a -> K (b (NP I as)) a
qp NP b as
np (forall {k} (xs :: [k]) (f :: k -> *).
SListI xs =>
NP (Projection f xs) xs
projections :: NP (Projection I as) as)
    {-# inline qps #-}
    qp :: ∀ a . b a -> Projection I as a -> K (b (NP I as)) a
    qp :: forall a. b a -> Projection I as a -> K (b (NP I as)) a
qp b a
par (Fn K (NP I as) a -> I a
proj) =
      forall k a (b :: k). a -> K a b
K (forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall a. I a -> a
unI forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NP I as) a -> I a
proj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a (b :: k). a -> K a b
K) b a
par)
    {-# inline qp #-}
{-# inline prodParams #-}

type GetEncoder :: (Type -> Type) -> Type -> Constraint
class GetEncoder b a where
  getEncoder :: b a -> Encoder a

instance GetEncoder FullCodec a where
  getEncoder :: FullCodec a -> Encoder a
getEncoder = forall a s. Getting a s a -> s -> a
view forall a. IsLabel "encoder" a => a
#encoder

instance GetEncoder Encoder a where
  getEncoder :: Encoder a -> Encoder a
getEncoder = forall a. a -> a
id

type GetDecoder :: (Type -> Type) -> Type -> Constraint
class GetDecoder b a where
  getDecoder :: b a -> Decoder a

instance GetDecoder FullCodec a where
  getDecoder :: FullCodec a -> Decoder a
getDecoder = forall a s. Getting a s a -> s -> a
view forall a. IsLabel "decoder" a => a
#decoder

type ProdEncoder :: (Type -> Type) -> Type -> [Type] -> Constraint
class ProdEncoder b a as | a -> as where
  prodEncoder :: NP b as -> Encoder a

instance (
    ConstructProd a as,
    All (GetEncoder b) as
  ) => ProdEncoder b a as where
    prodEncoder :: NP b as -> Encoder a
prodEncoder NP b as
np = forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
unZ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (GFrom a, Generic a) => a -> SOP I (GCode a)
gfrom forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< forall (as :: [*]) (b :: * -> *).
(Contravariant b, forall x. Monoid (b x), All Top as) =>
NP b as -> b (NP I as)
prodParams (forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
Proxy @(GetEncoder b)) forall (b :: * -> *) a. GetEncoder b a => b a -> Encoder a
getEncoder NP b as
np)

type ProdDecoder :: (Type -> Type) -> Type -> [Type] -> Constraint
class ProdDecoder b a as | a -> as where
  prodDecoder :: NP b as -> Decoder a

instance (
    ReifyProd a as,
    All (GetDecoder b) as
  ) => ProdDecoder b a as where
    prodDecoder :: NP b as -> Decoder a
prodDecoder NP b as
np = forall a. (GTo a, Generic a) => SOP I (GCode a) -> a
gto forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {l} (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *).
(SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) =>
h f xs -> f (h I xs)
hsequence (forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
Proxy @(GetDecoder b)) forall (b :: * -> *) a. GetDecoder b a => b a -> Decoder a
getDecoder NP b as
np)

type ProdCodec :: (Type -> Type) -> Type -> [Type] -> Constraint
class ProdCodec b a as | a -> as where
  prodCodec :: NP b as -> b a

instance (
    ProdDecoder FullCodec a as,
    ProdEncoder FullCodec a as
  ) => ProdCodec FullCodec a as where
    prodCodec :: NP FullCodec as -> FullCodec a
prodCodec NP FullCodec as
np =
      Codec {
        $sel:decoder:Codec :: Decoder a
decoder = forall (b :: * -> *) a (as :: [*]).
ProdDecoder b a as =>
NP b as -> Decoder a
prodDecoder NP FullCodec as
np,
        $sel:encoder:Codec :: Encoder a
encoder = forall (b :: * -> *) a (as :: [*]).
ProdEncoder b a as =>
NP b as -> Encoder a
prodEncoder NP FullCodec as
np
      }

instance (
    ProdEncoder Encoder a as
  ) => ProdCodec Encoder a as where
    prodCodec :: NP Encoder as -> Encoder a
prodCodec = forall (b :: * -> *) a (as :: [*]).
ProdEncoder b a as =>
NP b as -> Encoder a
prodEncoder