module Sqel.ReifyCodec where

import Data.Functor.Invariant (Invariant, invmap)
import Generics.SOP (I (I), NP (Nil, (:*)))
import qualified Hasql.Encoders as Encoders

import Sqel.Codec (
  ColumnDecoder (columnDecoder, columnDecoderNullable),
  ColumnEncoder (columnEncoder, columnEncoderIgnore, columnEncoderNullable),
  PrimColumn (primDecoder, primEncoder),
  fullPrimCodec,
  ignoreDecoder,
  )
import Sqel.Codec.PrimDecoder (ArrayDecoder (arrayDecoder), enumDecoder, readDecoder)
import Sqel.Codec.PrimEncoder (arrayEncoder)
import Sqel.Codec.Product (ProdCodec (prodCodec))
import Sqel.Codec.Sum (ConCodec (conCodec), SumCodec (sumCodec), ignoreEncoder)
import qualified Sqel.Data.Codec as Codec
import Sqel.Data.Codec (Codec (Codec), Decoder (Decoder), Encoder (Encoder), FullCodec, ValueCodec)
import Sqel.Data.Dd (
  Comp (Prod, Sum),
  CompInc,
  ConCol,
  Dd (Dd),
  DdK (DdK),
  DdStruct (DdComp, DdPrim),
  ProdType (Con, Reg),
  Struct (Comp, Prim),
  )
import Sqel.Data.Mods (
  ArrayColumn (ArrayColumn),
  EnumColumn (EnumColumn),
  Ignore (Ignore),
  Mods (Mods),
  Newtype (Newtype),
  Nullable (Nullable),
  ReadShowColumn (ReadShowColumn),
  )
import Sqel.Mods (PrimCodec (PrimCodec), PrimValueCodec, PrimValueEncoder)
import Sqel.SOP.Enum (EnumTable)

type CompCodec :: Comp -> CompInc -> Type -> (Type -> Type) -> [Type] -> Constraint
class CompCodec c i a b as where
  compCodec :: NP b as -> b a

instance (
    ProdCodec b a as
  ) => CompCodec ('Prod 'Reg) i a b as where
    compCodec :: NP b as -> b a
compCodec = forall (b :: * -> *) a (as :: [*]).
ProdCodec b a as =>
NP b as -> b a
prodCodec

instance (
    ConCodec b as
  ) => CompCodec ('Prod ('Con as)) i (ConCol name record fields as) b as where
    compCodec :: NP b as -> b (ConCol name record fields as)
compCodec = forall (b :: * -> *) (as :: [*]) (name :: Symbol) (record :: Bool)
       (fields :: [ProductField]).
ConCodec b as =>
NP b as -> b (ConCol name record fields as)
conCodec

instance (
    SumCodec b a as
  ) => CompCodec 'Sum i a b as where
    compCodec :: NP b as -> b a
compCodec = forall (b :: * -> *) a (as :: [*]).
SumCodec b a as =>
NP b as -> b a
sumCodec

class DefaultPrimCodec b a where
  defaultPrimCodec :: b a

instance (
    PrimColumn a
  ) => DefaultPrimCodec FullCodec a where
    defaultPrimCodec :: FullCodec a
defaultPrimCodec =
      Codec {
        $sel:encoder:Codec :: Encoder a
encoder = forall a. Params a -> Params () -> Encoder a
Encoder (forall (f :: * -> *) a. ColumnEncoder f => f a -> Params a
columnEncoder Value a
encoder) (forall (f :: * -> *) a b. ColumnEncoder f => f a -> Params b
columnEncoderIgnore Value a
encoder),
        $sel:decoder:Codec :: Decoder a
decoder = forall a. Row a -> Row () -> Decoder a
Decoder (forall (f :: * -> *) a. ColumnDecoder f => f a -> Row a
columnDecoder Value a
decoder) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a. Row (Maybe a)
ignoreDecoder)
      }
      where
        encoder :: Value a
encoder = forall a. PrimColumn a => Value a
primEncoder
        decoder :: Value a
decoder = forall a. PrimColumn a => Value a
primDecoder

instance (
    PrimColumn a
  ) => DefaultPrimCodec ValueCodec a where
    defaultPrimCodec :: ValueCodec a
defaultPrimCodec =
      Codec {
        $sel:encoder:Codec :: Value a
encoder = forall a. PrimColumn a => Value a
primEncoder,
        $sel:decoder:Codec :: Value a
decoder = forall a. PrimColumn a => Value a
primDecoder
      }

instance (
    PrimColumn a
  ) => DefaultPrimCodec Encoder a where
    defaultPrimCodec :: Encoder a
defaultPrimCodec =
      forall a. Params a -> Params () -> Encoder a
Encoder (forall (f :: * -> *) a. ColumnEncoder f => f a -> Params a
columnEncoder Value a
encoder) (forall (f :: * -> *) a b. ColumnEncoder f => f a -> Params b
columnEncoderIgnore Value a
encoder)
      where
        encoder :: Value a
encoder = forall a. PrimColumn a => Value a
primEncoder

instance (
    PrimColumn a
  ) => DefaultPrimCodec Encoders.Value a where
    defaultPrimCodec :: Value a
defaultPrimCodec = forall a. PrimColumn a => Value a
primEncoder

type DefaultCompCodec :: Comp -> CompInc -> (Type -> Type) -> Type -> [Type] -> Constraint
class DefaultCompCodec c i b a as where
  defaultCompCodec :: NP b as -> b a

instance (
    CompCodec c i a FullCodec as
  ) => DefaultCompCodec c i FullCodec a as where
    defaultCompCodec :: NP FullCodec as -> FullCodec a
defaultCompCodec = forall (c :: Comp) (i :: CompInc) a (b :: * -> *) (as :: [*]).
CompCodec c i a b as =>
NP b as -> b a
compCodec @c @i

instance (
    CompCodec c i a Encoder as
  ) => DefaultCompCodec c i Encoder a as where
    defaultCompCodec :: NP Encoder as -> Encoder a
defaultCompCodec = forall (c :: Comp) (i :: CompInc) a (b :: * -> *) (as :: [*]).
CompCodec c i a b as =>
NP b as -> b a
compCodec @c @i

class ReifyPrimCodec b ps a where
  reifyPrimCodec :: NP I ps -> b a

instance {-# overlappable #-} (
    ReifyPrimCodec b ps a
  ) => ReifyPrimCodec b (p : ps) a where
  reifyPrimCodec :: NP I (p : ps) -> b a
reifyPrimCodec (I x
_ :* NP I xs
ps) =
    forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec NP I xs
ps

instance ReifyPrimCodec ValueCodec (PrimValueCodec a : ps) a where
  reifyPrimCodec :: NP I (PrimValueCodec a : ps) -> ValueCodec a
reifyPrimCodec (I (PrimCodec ValueCodec a
c) :* NP I xs
_) = ValueCodec a
c

instance ReifyPrimCodec FullCodec (PrimValueCodec a : ps) a where
  reifyPrimCodec :: NP I (PrimValueCodec a : ps) -> FullCodec a
reifyPrimCodec (I (PrimCodec (Codec Value a
encoder Value a
decoder)) :* NP I xs
_) =
    Codec {
      $sel:encoder:Codec :: Encoder a
encoder = forall a. Params a -> Params () -> Encoder a
Encoder (forall (f :: * -> *) a. ColumnEncoder f => f a -> Params a
columnEncoder Value a
encoder) (forall (f :: * -> *) a b. ColumnEncoder f => f a -> Params b
columnEncoderIgnore Value a
encoder),
      $sel:decoder:Codec :: Decoder a
decoder = forall a. Row a -> Row () -> Decoder a
Decoder (forall (f :: * -> *) a. ColumnDecoder f => f a -> Row a
columnDecoder Value a
decoder) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a. Row (Maybe a)
ignoreDecoder)
    }

instance (
    ReifyPrimCodec ValueCodec ps a
  ) => ReifyPrimCodec FullCodec (Nullable : ps) (Maybe a) where
    reifyPrimCodec :: NP I (Nullable : ps) -> FullCodec (Maybe a)
reifyPrimCodec (I x
Nullable
Nullable :* NP I xs
ps) =
      Codec {
        $sel:encoder:Codec :: Encoder (Maybe a)
encoder = forall a. Params a -> Params () -> Encoder a
Encoder (forall (f :: * -> *) a. ColumnEncoder f => f a -> Params (Maybe a)
columnEncoderNullable Value a
encoder) (forall a b. Value a -> Params b
ignoreEncoder Value a
encoder),
        $sel:decoder:Codec :: Decoder (Maybe a)
decoder = forall a. Row a -> Row () -> Decoder a
Decoder (forall (f :: * -> *) a. ColumnDecoder f => f a -> Row (Maybe a)
columnDecoderNullable Value a
decoder) (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a. Row (Maybe a)
ignoreDecoder)
      }
      where
        Codec Value a
encoder Value a
decoder = forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec @ValueCodec NP I xs
ps

instance ReifyPrimCodec Encoders.Value (PrimValueEncoder a : ps) a where
  reifyPrimCodec :: NP I (PrimValueEncoder a : ps) -> Value a
reifyPrimCodec (I (PrimCodec Value a
e) :* NP I xs
_) = Value a
e

instance ReifyPrimCodec Encoder (PrimValueEncoder a : ps) a where
  reifyPrimCodec :: NP I (PrimValueEncoder a : ps) -> Encoder a
reifyPrimCodec (I (PrimCodec Value a
encoder) :* NP I xs
_) =
    forall a. Params a -> Params () -> Encoder a
Encoder (forall (f :: * -> *) a. ColumnEncoder f => f a -> Params a
columnEncoder Value a
encoder) (forall (f :: * -> *) a b. ColumnEncoder f => f a -> Params b
columnEncoderIgnore Value a
encoder)

-- TODO this could also produce NullableOrNot
instance (
    ReifyPrimCodec Encoders.Value ps a
  ) => ReifyPrimCodec Encoder (Nullable : ps) (Maybe a) where
    reifyPrimCodec :: NP I (Nullable : ps) -> Encoder (Maybe a)
reifyPrimCodec (I x
Nullable
Nullable :* NP I xs
ps) =
      forall a. Params a -> Params () -> Encoder a
Encoder (forall (f :: * -> *) a. ColumnEncoder f => f a -> Params (Maybe a)
columnEncoderNullable Value a
encoder) (forall a b. Value a -> Params b
ignoreEncoder Value a
encoder)
      where
        encoder :: Value a
encoder = forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec @Encoders.Value NP I xs
ps

instance (
    Show a,
    EnumTable a
  ) => ReifyPrimCodec FullCodec (EnumColumn : ps) a where
  reifyPrimCodec :: NP I (EnumColumn : ps) -> FullCodec a
reifyPrimCodec (I x
EnumColumn
EnumColumn :* NP I xs
_) =
    forall a. Value a -> Value a -> FullCodec a
fullPrimCodec (forall a. (a -> Text) -> Value a
Encoders.enum forall b a. (Show a, IsString b) => a -> b
show) forall a. EnumTable a => Value a
enumDecoder

instance (
    Show a,
    EnumTable a
  ) => ReifyPrimCodec ValueCodec (EnumColumn : ps) a where
  reifyPrimCodec :: NP I (EnumColumn : ps) -> ValueCodec a
reifyPrimCodec (I x
EnumColumn
EnumColumn :* NP I xs
_) =
    forall {k} (e :: k -> *) (d :: k -> *) (a :: k).
e a -> d a -> Codec e d a
Codec (forall a. (a -> Text) -> Value a
Encoders.enum forall b a. (Show a, IsString b) => a -> b
show) forall a. EnumTable a => Value a
enumDecoder

instance (
    Show a,
    Read a
  ) => ReifyPrimCodec FullCodec (ReadShowColumn : ps) a where
  reifyPrimCodec :: NP I (ReadShowColumn : ps) -> FullCodec a
reifyPrimCodec (I x
ReadShowColumn
ReadShowColumn :* NP I xs
_) =
    forall a. Value a -> Value a -> FullCodec a
fullPrimCodec (forall a. (a -> Text) -> Value a
Encoders.enum forall b a. (Show a, IsString b) => a -> b
show) forall a. Read a => Value a
readDecoder

instance (
    Show a,
    Read a
  ) => ReifyPrimCodec ValueCodec (ReadShowColumn : ps) a where
  reifyPrimCodec :: NP I (ReadShowColumn : ps) -> ValueCodec a
reifyPrimCodec (I x
ReadShowColumn
ReadShowColumn :* NP I xs
_) =
    forall {k} (e :: k -> *) (d :: k -> *) (a :: k).
e a -> d a -> Codec e d a
Codec (forall a. (a -> Text) -> Value a
Encoders.enum forall b a. (Show a, IsString b) => a -> b
show) forall a. Read a => Value a
readDecoder

instance (
    ReifyPrimCodec ValueCodec ps a,
    Foldable f,
    ArrayDecoder f a
  ) => ReifyPrimCodec ValueCodec (ArrayColumn f : ps) (f a) where
  reifyPrimCodec :: NP I (ArrayColumn f : ps) -> ValueCodec (f a)
reifyPrimCodec (I x
ArrayColumn f
ArrayColumn :* NP I xs
ps) =
    forall {k} (e :: k -> *) (d :: k -> *) (a :: k).
e a -> d a -> Codec e d a
Codec (forall (f :: * -> *) a. Foldable f => Value a -> Value (f a)
arrayEncoder Value a
encoder) (forall (f :: * -> *) a. ArrayDecoder f a => Value a -> Value (f a)
arrayDecoder Value a
decoder)
      where
        Codec Value a
encoder Value a
decoder = forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec @ValueCodec NP I xs
ps

instance (
    ReifyPrimCodec ValueCodec ps a,
    Foldable f,
    ArrayDecoder f a
  ) => ReifyPrimCodec FullCodec (ArrayColumn f : ps) (f a) where
  reifyPrimCodec :: NP I (ArrayColumn f : ps) -> FullCodec (f a)
reifyPrimCodec (I x
ArrayColumn f
ArrayColumn :* NP I xs
ps) =
    forall a. Value a -> Value a -> FullCodec a
fullPrimCodec (forall (f :: * -> *) a. Foldable f => Value a -> Value (f a)
arrayEncoder Value a
encoder) (forall (f :: * -> *) a. ArrayDecoder f a => Value a -> Value (f a)
arrayDecoder Value a
decoder)
      where
        Codec Value a
encoder Value a
decoder = forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec @ValueCodec NP I xs
ps

instance {-# overlappable #-} (
    ReifyPrimCodec c mods w,
    Invariant c
  ) => ReifyPrimCodec c (Newtype a w : mods) a where
  reifyPrimCodec :: NP I (Newtype a w : mods) -> c a
reifyPrimCodec (I (Newtype a -> w
unwrap w -> a
wrap) :* NP I xs
mods) =
    forall (f :: * -> *) a b.
Invariant f =>
(a -> b) -> (b -> a) -> f a -> f b
invmap w -> a
wrap a -> w
unwrap (forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec NP I xs
mods)

instance (
    ReifyPrimCodec Encoders.Value mods w
  ) => ReifyPrimCodec Encoders.Value (Newtype a w : mods) a where
  reifyPrimCodec :: NP I (Newtype a w : mods) -> Value a
reifyPrimCodec (I (Newtype a -> w
unwrap w -> a
_) :* NP I xs
mods) =
    a -> w
unwrap forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< (forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec NP I xs
mods)

instance ReifyPrimCodec FullCodec (Ignore : ps) a where
  reifyPrimCodec :: NP I (Ignore : ps) -> FullCodec a
reifyPrimCodec (I x
Ignore
Ignore :* NP I xs
_) =
    forall {k} (e :: k -> *) (d :: k -> *) (a :: k).
e a -> d a -> Codec e d a
Codec (forall a. Params a -> Params () -> Encoder a
Encoder forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty) (forall a. Row a -> Row () -> Decoder a
Decoder (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err))
    where
      err :: String
err = String
"ignored column was used"

instance ReifyPrimCodec Encoder (Ignore : ps) a where
  reifyPrimCodec :: NP I (Ignore : ps) -> Encoder a
reifyPrimCodec (I x
Ignore
Ignore :* NP I xs
_) =
    forall a. Params a -> Params () -> Encoder a
Encoder forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance (
    DefaultPrimCodec b a
  ) => ReifyPrimCodec b '[] a where
    reifyPrimCodec :: NP I '[] -> b a
reifyPrimCodec NP I '[]
_ = forall {k} (b :: k -> *) (a :: k). DefaultPrimCodec b a => b a
defaultPrimCodec

class ReifyCompCodec b c i ps as a where
  reifyCompCodec :: NP I ps -> NP b as -> b a

instance (
    DefaultCompCodec c i b a as
  ) => ReifyCompCodec b c i ps as a where
    reifyCompCodec :: NP I ps -> NP b as -> b a
reifyCompCodec NP I ps
_ NP b as
sub =
      forall (c :: Comp) (i :: CompInc) (b :: * -> *) a (as :: [*]).
DefaultCompCodec c i b a as =>
NP b as -> b a
defaultCompCodec @c @i NP b as
sub

type ReifyCodec :: (Type -> Type) -> DdK -> Type -> Constraint
class ReifyCodec b s a | s -> a where
  reifyCodec :: Dd s -> b a

instance (
    ReifyPrimCodec b ps a
  ) => ReifyCodec b ('DdK sel ps a 'Prim) a where
    reifyCodec :: Dd ('DdK sel ps a 'Prim) -> b a
reifyCodec (Dd SelW sel
_ (Mods NP I mods
ps) DdStruct s1
DdPrim) =
      forall {k} (b :: k -> *) (ps :: [*]) (a :: k).
ReifyPrimCodec b ps a =>
NP I ps -> b a
reifyPrimCodec @b NP I mods
ps

instance (
    ReifyCodecComp b sub as,
    ReifyCompCodec b c i ps as a
  ) => ReifyCodec b ('DdK sel ps a ('Comp tsel c i sub)) a where
    reifyCodec :: Dd ('DdK sel ps a ('Comp tsel c i sub)) -> b a
reifyCodec (Dd SelW sel
_ (Mods NP I mods
ps) (DdComp TSelW sel
_ DdSort c
_ DdInc i
_ NP Dd sub
sub)) =
      forall {k} {k} {k} (b :: k -> *) (c :: k) (i :: k) (ps :: [*])
       (as :: [k]) (a :: k).
ReifyCompCodec b c i ps as a =>
NP I ps -> NP b as -> b a
reifyCompCodec @b @c @i @ps @as NP I mods
ps (forall (b :: * -> *) (s :: [DdK]) (as :: [*]).
ReifyCodecComp b s as =>
NP Dd s -> NP b as
reifyCodecComp @b @sub NP Dd sub
sub)

-- TODO this is probably only necessary because of a bug in GHC that's fixed in master
type ReifyCodecComp :: (Type -> Type) -> [DdK] -> [Type] -> Constraint
class ReifyCodecComp b s as | s -> as where
  reifyCodecComp :: NP Dd s -> NP b as

instance ReifyCodecComp b '[] '[] where
  reifyCodecComp :: NP Dd '[] -> NP b '[]
reifyCodecComp NP Dd '[]
Nil = forall {k} (a :: k -> *). NP a '[]
Nil

instance (
    ReifyCodec b s a,
    ReifyCodecComp b ss as
  ) => ReifyCodecComp b (s : ss) (a : as) where
  reifyCodecComp :: NP Dd (s : ss) -> NP b (a : as)
reifyCodecComp (Dd x
d :* NP Dd xs
ds) = forall (b :: * -> *) (s :: DdK) a. ReifyCodec b s a => Dd s -> b a
reifyCodec Dd x
d forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* forall (b :: * -> *) (s :: [DdK]) (as :: [*]).
ReifyCodecComp b s as =>
NP Dd s -> NP b as
reifyCodecComp NP Dd xs
ds