module Sqel.Codec.Sum where

import Data.Functor.Contravariant.Divisible (choose)
import Data.Functor.Invariant (Invariant (invmap))
import Exon (exon)
import Generics.SOP (
  All2,
  HIndex (hindex),
  I,
  NP (Nil, (:*)),
  NS (S, Z),
  SListI,
  SListI2,
  SOP (SOP),
  Top,
  hcfoldMap,
  hctraverse_,
  hmap,
  hsequence,
  unSOP,
  )
import Generics.SOP.GGP (gfrom, gto)
import Hasql.Decoders (Row)
import qualified Hasql.Encoders as Encoders
import qualified Hasql.Encoders as Encoder
import Hasql.Encoders (Params)
import Lens.Micro ((^.))
import Lens.Micro.Extras (view)
import qualified Sqel.Data.Codec as Codec
import Sqel.Data.Codec (Codec (Codec), Decoder (Decoder), Encoder (Encoder), FullCodec)
import Sqel.Data.Dd (ConCol (ConCol, unConCol))
import Sqel.SOP.Constraint (ConstructSOP, ReifySOP)

import Sqel.Codec.Product (prodParams)

unconsNS ::
  NS (NP I) (ds : dss) ->
  Either (NP I ds) (NS (NP I) dss)
unconsNS :: forall (ds :: [*]) (dss :: [[*]]).
NS (NP I) (ds : dss) -> Either (NP I ds) (NS (NP I) dss)
unconsNS = \case
  Z NP I x
x -> forall a b. a -> Either a b
Left NP I x
x
  S NS (NP I) xs
x -> forall a b. b -> Either a b
Right NS (NP I) xs
x

newtype ConB b as =
  ConB { forall (b :: * -> *) (as :: [*]). ConB b as -> b (NP I as)
unConB :: b (NP I as) }

readNull ::
  ∀ as .
  Decoder (NP I as) ->
  Row ()
readNull :: forall (as :: [*]). Decoder (NP I as) -> Row ()
readNull Decoder (NP I as)
rs =
  Decoder (NP I as)
rs forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "decodeNulls" a => a
#decodeNulls

readNulls ::
  ∀ ass .
  SListI2 ass =>
  NP (ConB Decoder) ass ->
  Row ()
readNulls :: forall (ass :: [[*]]).
SListI2 ass =>
NP (ConB Decoder) ass -> Row ()
readNulls NP (ConB Decoder) ass
cons =
  forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (g :: * -> *) (proxy :: (k -> Constraint) -> *)
       (f :: k -> *).
(HTraverse_ h, AllN h c xs, Applicative g) =>
proxy c -> (forall (a :: k). c a => f a -> g ()) -> h f xs -> g ()
hctraverse_ (forall {k} (t :: k). Proxy t
Proxy @SListI) (forall (as :: [*]). Decoder (NP I as) -> Row ()
readNull forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (as :: [*]). ConB b as -> b (NP I as)
unConB) NP (ConB Decoder) ass
cons

sumRows ::
  All2 Top ass =>
  NP (ConB Decoder) ass ->
  Int64 ->
  Row (NS (NP I) ass)
sumRows :: forall (ass :: [[*]]).
All2 Top ass =>
NP (ConB Decoder) ass -> Int64 -> Row (NS (NP I) ass)
sumRows (ConB Decoder (NP I x)
con :* NP (ConB Decoder) xs
cons) Int64
0 =
  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
<$> (Decoder (NP I x)
con forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "decodeValue" a => a
#decodeValue) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (ass :: [[*]]).
SListI2 ass =>
NP (ConB Decoder) ass -> Row ()
readNulls NP (ConB Decoder) xs
cons
sumRows (ConB Decoder (NP I x)
con :* NP (ConB Decoder) xs
cons) Int64
index = do
  forall (as :: [*]). Decoder (NP I as) -> Row ()
readNull Decoder (NP I x)
con
  forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ass :: [[*]]).
All2 Top ass =>
NP (ConB Decoder) ass -> Int64 -> Row (NS (NP I) ass)
sumRows NP (ConB Decoder) xs
cons (Int64
index forall a. Num a => a -> a -> a
- Int64
1)
sumRows NP (ConB Decoder) ass
Nil Int64
index =
  forall (m :: * -> *) a. MonadFail m => String -> m a
fail [exon|invalid index into sum type in database: #{show index}|]

ignoreEncoder :: Encoder.Value a -> Params b
ignoreEncoder :: forall a b. Value a -> Params b
ignoreEncoder Value a
v =
  forall a b. a -> b -> a
const forall a. Maybe a
Nothing forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< forall a. NullableOrNot Value a -> Params a
Encoders.param (forall (encoder :: * -> *) a.
encoder a -> NullableOrNot encoder (Maybe a)
Encoders.nullable Value a
v)

writeNull ::
  ∀ a as .
  ConB Encoder as ->
  Params a
writeNull :: forall a (as :: [*]). ConB Encoder as -> Params a
writeNull (ConB Encoder (NP I as)
enc) =
  forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall (f :: * -> *). Applicative f => f ()
unit (Encoder (NP I as)
enc forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "encodeNulls" a => a
#encodeNulls)

writeNulls ::
  ∀ a ass .
  SListI2 ass =>
  NP (ConB Encoder) ass ->
  Params a
writeNulls :: forall a (ass :: [[*]]).
SListI2 ass =>
NP (ConB Encoder) ass -> Params a
writeNulls =
  forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) m (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HTraverse_ h, AllN h c xs, Monoid m) =>
proxy c -> (forall (a :: k). c a => f a -> m) -> h f xs -> m
hcfoldMap (forall {k} (t :: k). Proxy t
Proxy @SListI) forall a (as :: [*]). ConB Encoder as -> Params a
writeNull

sumParams ::
  All2 Top ass =>
  NP (ConB Encoder) ass ->
  Params (NS (NP I) ass)
sumParams :: forall (ass :: [[*]]).
All2 Top ass =>
NP (ConB Encoder) ass -> Params (NS (NP I) ass)
sumParams = \case
  ConB Encoder x
con :* NP (ConB Encoder) xs
cons ->
    forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose forall (ds :: [*]) (dss :: [[*]]).
NS (NP I) (ds : dss) -> Either (NP I ds) (NS (NP I) dss)
unconsNS Params (NP I x)
inhabited Params (NS (NP I) xs)
uninhabited
    where
      inhabited :: Params (NP I x)
inhabited = (forall (b :: * -> *) (as :: [*]). ConB b as -> b (NP I as)
unConB ConB Encoder x
con) forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "encodeValue" a => a
#encodeValue forall a. Semigroup a => a -> a -> a
<> forall a (ass :: [[*]]).
SListI2 ass =>
NP (ConB Encoder) ass -> Params a
writeNulls NP (ConB Encoder) xs
cons
      uninhabited :: Params (NS (NP I) xs)
uninhabited = forall a (as :: [*]). ConB Encoder as -> Params a
writeNull ConB Encoder x
con forall a. Semigroup a => a -> a -> a
<> forall (ass :: [[*]]).
All2 Top ass =>
NP (ConB Encoder) ass -> Params (NS (NP I) ass)
sumParams NP (ConB Encoder) xs
cons
  NP (ConB Encoder) ass
Nil ->
    forall a. Monoid a => a
mempty

type WrapConB :: (Type -> Type) -> [[Type]] -> [Type] -> Constraint
class WrapConB b ass as where
  wrapConB :: NP b as -> NP (ConB b) ass

instance WrapConB b '[] '[] where
  wrapConB :: NP b '[] -> NP (ConB b) '[]
wrapConB NP b '[]
Nil = forall {k} (a :: k -> *). NP a '[]
Nil

instance (
    Invariant b,
    WrapConB b ass as
  ) => WrapConB b (as' : ass) (ConCol name record fields as' : as) where
    wrapConB :: NP b (ConCol name record fields as' : as)
-> NP (ConB b) (as' : ass)
wrapConB (b x
b :* NP b xs
bs) =
      forall (b :: * -> *) (as :: [*]). b (NP I as) -> ConB b as
ConB (forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap forall (name :: Symbol) (record :: Bool) (fields :: [ProductField])
       (as :: [*]).
ConCol name record fields as -> NP I as
unConCol forall (name :: Symbol) (record :: Bool) (fields :: [ProductField])
       (as :: [*]).
NP I as -> ConCol name record fields as
ConCol b x
b) forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall (b :: * -> *) (ass :: [[*]]) (as :: [*]).
WrapConB b ass as =>
NP b as -> NP (ConB b) ass
wrapConB NP b xs
bs

encodeValue ::
  ConstructSOP a ass =>
  Encoder Int64 ->
  NP (ConB Encoder) ass ->
  Params a
encodeValue :: forall a (ass :: [[*]]).
ConstructSOP a ass =>
Encoder Int64 -> NP (ConB Encoder) ass -> Params a
encodeValue (Encoder Params Int64
indexParams Params ()
_) NP (ConB Encoder) ass
wrapped =
  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
>$< (Params (NS (NP I) ass)
indexEncoder forall a. Semigroup a => a -> a -> a
<> forall (ass :: [[*]]).
All2 Top ass =>
NP (ConB Encoder) ass -> Params (NS (NP I) ass)
sumParams NP (ConB Encoder) ass
wrapped)
  where
    indexEncoder :: Params (NS (NP I) ass)
indexEncoder = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (xs :: l).
HIndex h =>
h f xs -> Int
hindex) forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Params Int64
indexParams

type SumCodec :: (Type -> Type) -> Type -> [Type] -> Constraint
class SumCodec b a as where
  sumCodec :: NP b as -> b a

-- TODO add null builders
instance (
    ReifySOP a ass,
    ConstructSOP a ass,
    WrapConB FullCodec ass as
  ) => SumCodec FullCodec a (Int64 : as) where
    sumCodec :: NP FullCodec (Int64 : as) -> FullCodec a
sumCodec (Codec Encoder x
index (Decoder Row x
indexRow Row ()
_) :* NP FullCodec xs
conCodecs) =
      Codec {
        $sel:decoder:Codec :: Decoder a
decoder = forall a. Row a -> Row () -> Decoder a
Decoder Row a
decodeValue forall (f :: * -> *). Applicative f => f ()
unit,
        $sel:encoder:Codec :: Encoder a
encoder = forall a. Params a -> Params () -> Encoder a
Encoder (forall a (ass :: [[*]]).
ConstructSOP a ass =>
Encoder Int64 -> NP (ConB Encoder) ass -> Params a
encodeValue Encoder x
index (forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (forall (b :: * -> *) (as :: [*]). b (NP I as) -> ConB b as
ConB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall a. IsLabel "encoder" a => a
#encoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (as :: [*]). ConB b as -> b (NP I as)
unConB) NP (ConB FullCodec) ass
wrapped)) forall a. Monoid a => a
mempty
      }
      where
        decodeValue :: Row a
decodeValue =
          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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (ass :: [[*]]).
All2 Top ass =>
NP (ConB Decoder) ass -> Int64 -> Row (NS (NP I) ass)
sumRows NP (ConB Decoder) ass
decs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Row x
indexRow)
        decs :: NP (ConB Decoder) ass
decs =
          forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (forall (b :: * -> *) (as :: [*]). b (NP I as) -> ConB b as
ConB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall a. IsLabel "decoder" a => a
#decoder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (as :: [*]). ConB b as -> b (NP I as)
unConB) NP (ConB FullCodec) ass
wrapped
        wrapped :: NP (ConB FullCodec) ass
wrapped =
          forall (b :: * -> *) (ass :: [[*]]) (as :: [*]).
WrapConB b ass as =>
NP b as -> NP (ConB b) ass
wrapConB NP FullCodec xs
conCodecs

instance (
    ConstructSOP a ass,
    WrapConB Encoder ass as
  ) => SumCodec Encoder a (Int64 : as) where
    sumCodec :: NP Encoder (Int64 : as) -> Encoder a
sumCodec (Encoder x
index :* NP Encoder xs
conCodecs) =
      forall a. Params a -> Params () -> Encoder a
Encoder (forall a (ass :: [[*]]).
ConstructSOP a ass =>
Encoder Int64 -> NP (ConB Encoder) ass -> Params a
encodeValue Encoder x
index NP (ConB Encoder) ass
wrapped) forall a. Monoid a => a
mempty
      where
        wrapped :: NP (ConB Encoder) ass
wrapped = forall (b :: * -> *) (ass :: [[*]]) (as :: [*]).
WrapConB b ass as =>
NP b as -> NP (ConB b) ass
wrapConB NP Encoder xs
conCodecs

type ConCodec :: (Type -> Type) -> [Type] -> Constraint
class ConCodec b as where
  conCodec :: NP b as -> b (ConCol name record fields as)

instance SListI as => ConCodec FullCodec as where
  conCodec :: forall (name :: Symbol) (record :: Bool)
       (fields :: [ProductField]).
NP FullCodec as -> FullCodec (ConCol name record fields as)
conCodec NP FullCodec as
np =
    Codec {
      $sel:decoder:Codec :: Decoder (ConCol name record fields as)
decoder = forall (name :: Symbol) (record :: Bool) (fields :: [ProductField])
       (as :: [*]).
NP I as -> ConCol name record fields as
ConCol 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 -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (forall a s. Getting a s a -> s -> a
view forall a. IsLabel "decoder" a => a
#decoder) NP FullCodec as
np),
      $sel:encoder:Codec :: Encoder (ConCol name record fields as)
encoder = forall (name :: Symbol) (record :: Bool) (fields :: [ProductField])
       (as :: [*]).
ConCol name record fields as -> NP I as
unConCol 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 -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (forall a s. Getting a s a -> s -> a
view forall a. IsLabel "encoder" a => a
#encoder) NP FullCodec as
np)
    }

instance SListI as => ConCodec Encoder as where
    conCodec :: forall (name :: Symbol) (record :: Bool)
       (fields :: [ProductField]).
NP Encoder as -> Encoder (ConCol name record fields as)
conCodec NP Encoder as
np = forall (name :: Symbol) (record :: Bool) (fields :: [ProductField])
       (as :: [*]).
ConCol name record fields as -> NP I as
unConCol 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 NP Encoder as
np