{-# LANGUAGE UndecidableInstances #-}
module PgSchema.Ann where

import Data.Aeson
import Data.Aeson.Types (Pair, Parser)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as Key
import Data.Coerce
import Data.Singletons.TH (genDefunSymbols)
import Data.Type.Bool
import Data.Typeable
import Data.Text qualified as T
import Data.Kind
import Database.PostgreSQL.Simple.ToField(ToField(..), Action, toJSONField)
import Database.PostgreSQL.Simple.FromField(FromField(..), fromJSONField)
import Database.PostgreSQL.Simple.ToRow(ToRow(..))
import Database.PostgreSQL.Simple.FromRow(FromRow(..), RowParser, field)
import GHC.Generics
import GHC.Int
import GHC.TypeLits
import GHC.TypeError as TE
import PgSchema.Schema
import PgSchema.Types
import PgSchema.Utils.Internal
import Data.Singletons as SP
import PgSchema.Utils.TF as SP



-- $setup
-- >>> import PgSchema.Schema.Catalog
-- >>> import Database.PostgreSQL.Simple
-- >>> conn <- connectPostgreSQL ""

-- | Type-level annotation: enforce constraints at compile time
-- and drive demoted types used to generate correct SQL.
-- 'annRen' and 'annSch' are fixed for the whole DML-operation.
-- 'annDepth' and 'annTab' are changed while traversing the structure of the ADT.
--
data Ann = Ann
  { Ann -> Renamer
annRen  :: Renamer -- ^ Renamer to convert Haskell names to database names.
  , Ann -> *
annSch  :: Type    -- ^ Schema with tables, relations and types.
  , Ann -> Nat
annDepth :: Nat
  -- ^ Depth of the nested relations. It is mostly used to prevent cycles in types.
  , Ann -> NameNSK
annTab  :: NameNSK -- ^ Name of the root table.
  }

type family AnnSch (ann :: Ann) where
  AnnSch ('Ann ren sch depth tab) = sch

data ColInfo (p :: Type) = ColInfo
  { forall p. ColInfo p -> SymNat
ciField   :: SymNat
  , forall p. ColInfo p -> *
ciType    :: Type
  , forall p. ColInfo p -> Symbol
ciDbField :: Symbol
  , forall p. ColInfo p -> RecField' Symbol p
ciInfo    :: RecField' Symbol p
  }

-- | Renamer is a type-level function from 'Symbol' to 'Symbol'.
type Renamer = Symbol ~> Symbol

-- | Apply renamer to symbol.
--
--  Like 'Data.Singletons.Apply' but specialized for 'Symbol'.
--
-- To make your own Renamer, typically you make
--
-- * data MyRenamer :: Renamer
-- * closed type family: `type family MyRenamerImpl (s :: Symbol) :: Symbol where ... `
-- * type instance ApplyRenamer MyRenamer s = MyRenamerImpl s
--
type family ApplyRenamer (renamer :: Renamer) (s :: Symbol) :: Symbol

-- | Renamer that does not change the symbol.
data RenamerId :: Renamer

type instance ApplyRenamer RenamerId s = s

--------------------------------------------------------------------------------
-- Case dispatch
--------------------------------------------------------------------------------

data ColsCase = NonGenericCase | GenericCase

type family ColsCaseOf (r :: Type) :: ColsCase where
  ColsCaseOf (a :. b)              = 'NonGenericCase
  ColsCaseOf ((_ :: Symbol) := _) = 'NonGenericCase
  ColsCaseOf r = 'GenericCase

--------------------------------------------------------------------------------
-- CCols / CColsCase
--------------------------------------------------------------------------------

class CColsCase ann r (ColsCaseOf r) => CCols ann r where
  type Cols ann r :: [ColInfo NameNSK]

instance CColsCase ann r (ColsCaseOf r) => CCols ann r where
  type Cols ann r = ColsWithCase ann r (ColsCaseOf r)

class CColsCase (ann :: Ann) (r :: Type) (c :: ColsCase) where
  type ColsWithCase ann r c :: [ColInfo NameNSK]

instance CColsCase ann r 'NonGenericCase where
  type ColsWithCase ann r 'NonGenericCase = ColsNonGeneric ann r

instance Generic r => CColsCase ann r 'GenericCase where
  type ColsWithCase ann r 'GenericCase = GCols ann (Rep r)

--------------------------------------------------------------------------------
-- ColsNonGeneric (closed TF: (:.) and (:=))
--------------------------------------------------------------------------------

type family ColsNonGeneric (ann :: Ann) r :: [ColInfo NameNSK] where
  ColsNonGeneric ann (a :. b) = Normalize (Cols ann a SP.++ Cols ann b)
  ColsNonGeneric ann (fld := t) = Col ann fld t

--------------------------------------------------------------------------------
-- Col / ColFI (per-field, reused by GCols)
--------------------------------------------------------------------------------

type family Col (ann :: Ann) (fld :: Symbol) t :: [ColInfo NameNSK] where
  Col ann fld () = '[]
  Col ann fld (Aggr ACount Int64) =
    '[ 'ColInfo '(fld, 0) (Aggr ACount Int64) fld
      ('RFAggr ('FldDef ("pg_catalog" ->> "int8") False False) 'ACount 'True) ]
  Col ann fld (Aggr' ACount Int64) =
    '[ 'ColInfo '(fld, 0) (Aggr' ACount Int64) fld
      ('RFAggr ('FldDef ("pg_catalog" ->> "int8") False False) 'ACount 'True) ]
  Col ('Ann ren sch d tab) fld t =
    ColFI ('Ann ren sch d tab) fld (TDBFieldInfo sch tab (ApplyRenamer ren fld)) t

type family ColFI (ann :: Ann) (fld :: Symbol) (fi :: RecFieldK NameNSK) t
  :: [ColInfo NameNSK] where
    ColFI ('Ann ren sch _ _) fld ('RFPlain ('FldDef tn False def)) (PgArr t) =
      '[ 'ColInfo '(fld, 0) (PgTag (TypElem (TTypDef sch tn)) (PgArr t))
        (ApplyRenamer ren fld) (RFPlain ('FldDef tn False def))]
    ColFI ('Ann ren sch _ _) fld ('RFPlain ('FldDef tn True def)) (Maybe (PgArr t)) =
      '[ 'ColInfo '(fld, 0) (Maybe (PgTag (TypElem (TTypDef sch tn)) (PgArr t)))
        (ApplyRenamer ren fld) (RFPlain ('FldDef tn True def))]
    -- RFFromHere: Maybe r
    ColFI ('Ann ren sch d _) fld ('RFFromHere (toTab :: NameNSK) refs) (Maybe r) =
      '[ 'ColInfo '(fld, 0) (Maybe (PgTag (AnnRefTabDepth ('Ann ren sch d toTab) toTab) r))
        (ApplyRenamer ren fld) ('RFFromHere toTab refs) ]
    -- RFFromHere: r (non-Maybe)
    ColFI ('Ann ren sch d _) fld ('RFFromHere (toTab :: NameNSK) refs) r =
      '[ 'ColInfo '(fld, 0) (PgTag (AnnRefTabDepth ('Ann ren sch d toTab) toTab) r)
        (ApplyRenamer ren fld) ('RFFromHere toTab refs) ]
    ColFI ('Ann ren sch d _) fld ('RFToHere (fromTab :: NameNSK) refs) [t] =
      '[ 'ColInfo '(fld, 0) [PgTag (AnnRefTabDepth ('Ann ren sch d fromTab) fromTab) t]
        (ApplyRenamer ren fld) ('RFToHere fromTab refs) ]
    ColFI ('Ann ren sch d _) fld fd t = '[ 'ColInfo '(fld, 0) t (ApplyRenamer ren fld) fd ]
    ColFI ann fld ('RFSelfRef tab refs) [t] = ColFI ann fld ('RFToHere tab refs) [t]
    ColFI ann fld ('RFSelfRef tab refs) t = ColFI ann fld ('RFFromHere tab refs) t
--------------------------------------------------------------------------------
-- GCols (closed TF: Generic Rep)
--------------------------------------------------------------------------------

type family GCols ann (rep :: Type -> Type) :: [ColInfo NameNSK] where
    GCols ann (D1 d (C1 c flds)) = Normalize (GCols ann flds)
    GCols ann (a :*: b) = GCols ann a SP.++ GCols ann b
    GCols ann (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) = Col ann fld t
    GCols ann rep = TypeError
      ( Text "Only Product types with fields are supported in pg-schema."
      :$$: Text "(sum types, empty, or missing field selector are not supported)"
      :$$: Text ""
      :$$: Text "But I've got " :<>: ShowType rep )

--------------------------------------------------------------------------------
-- Normalize (SymNat numbering)
--------------------------------------------------------------------------------

type family AddNum (xs :: [ColInfo p]) (cnts :: [SymNat])
  (accCnts :: [SymNat]) :: [ColInfo p]
  where
    AddNum '[] _ _ = '[]
    AddNum ('ColInfo '(s,_) t f fi : xs) '[] accCnts =
      'ColInfo '(s,0) t f fi ': AddNum xs ('(s,0) ': accCnts) '[]
    AddNum ('ColInfo '(s,_) t f fi : xs) ('(s,n) ': rest) accCnts =
      'ColInfo '(s, n+1) t f fi ': AddNum xs (('(s,n+1) ': accCnts) SP.++ rest) '[]
    AddNum ('ColInfo '(s,x) t f fi : xs) ('(s',n) ': rest) accCnts =
      AddNum ('ColInfo '(s,x) t f fi : xs) rest ('(s',n) ': accCnts)

type Normalize xs = AddNum xs '[] '[]

--------------------------------------------------------------------------------
-- ToJSON for PgTag Ann r
--------------------------------------------------------------------------------

instance
  (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, ToJSONCols ann colsCase cols r)
  => ToJSON (PgTag ann r) where
    toJSON :: PgTag ann r -> Value
toJSON (PgTag r
r) = Object -> Value
Object ([(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList (forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToJSONCols ann colsCase cols r =>
r -> [(Key, Value)]
toPairs @ann @colsCase @cols r
r))
    toEncoding :: PgTag ann r -> Encoding
toEncoding (PgTag r
r) = Series -> Encoding
pairs (((Key, Value) -> Series) -> [(Key, Value)] -> Series
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Key -> Value -> Series) -> (Key, Value) -> Series
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Value -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
(.=)) ([(Key, Value)] -> Series) -> [(Key, Value)] -> Series
forall a b. (a -> b) -> a -> b
$ forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToJSONCols ann colsCase cols r =>
r -> [(Key, Value)]
toPairs @ann @colsCase @cols r
r)

instance
  (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromJSONCols ann colsCase cols r)
  => FromJSON (PgTag ann r) where
   parseJSON :: Value -> Parser (PgTag ann r)
parseJSON Value
v = r -> PgTag ann r
forall {k} (s :: k) t. t -> PgTag s t
PgTag (r -> PgTag ann r) -> Parser r -> Parser (PgTag ann r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromJSONCols ann colsCase cols r =>
Value -> Parser r
parseJSONCols @ann @colsCase @cols Value
v

-- >>> type AnnRel = 'Ann RenamerId PgCatalog (PGC "pg_constraint")
-- >>> rel = PgRelation{ constraint__namespace = PgTag "a", conname = "b", constraint__class = PgClassShort (PgTag "c") "d", constraint__fclass = PgClassShort (PgTag "e") "f", conkey = pgArr' [1,2], confkey = pgArr' [] }
-- >>> rec = "conname" =: ("x" :: T.Text) :. "conname" =: ("z" :: T.Text) :. rel :. "conname" =: ("y" :: T.Text)
-- >>> toJSON $ PgTag @AnnRel rec
-- >>> fromJSON (toJSON $ PgTag @AnnRel rec) == Success (PgTag @AnnRel rec)
-- Object (fromList [("confkey",Array []),("conkey",Array [Number 1.0,Number 2.0]),("conname",String "x"),("conname___1",String "z"),("conname___2",String "b"),("conname___3",String "y"),("constraint__class",Object (fromList [("class__namespace",Object (fromList [("nspname",String "c")])),("relname",String "d")])),("constraint__fclass",Object (fromList [("class__namespace",Object (fromList [("nspname",String "e")])),("relname",String "f")])),("constraint__namespace",Object (fromList [("nspname",String "a")]))])
-- True


class ToJSONCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r where
  toPairs :: r -> [Pair]

class FromJSONCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r where
  parseJSONCols :: Value -> Parser r

-- (:=)
--------------------------------------------------------------------------------
-- NonGeneric: (:=) и (:.)
--------------------------------------------------------------------------------
instance ToJSONCols ann 'NonGenericCase '[] (fld := ()) where
  toPairs :: (fld := ()) -> [(Key, Value)]
toPairs fld := ()
_ = []

instance FromJSONCols ann 'NonGenericCase '[] (fld := ()) where
  parseJSONCols :: Value -> Parser (fld := ())
parseJSONCols = Parser (fld := ()) -> Value -> Parser (fld := ())
forall a. a -> Value -> a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser (fld := ()) -> Value -> Parser (fld := ()))
-> Parser (fld := ()) -> Value -> Parser (fld := ())
forall a b. (a -> b) -> a -> b
$ (fld := ()) -> Parser (fld := ())
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> fld := ()
forall {k} (s :: k) t. t -> PgTag s t
PgTag ())

instance (KnownSymNat sn, ToJSON t, Coercible v t)
  => ToJSONCols ann 'NonGenericCase '[ 'ColInfo sn t db fi ] (fld := v) where
    toPairs :: (fld := v) -> [(Key, Value)]
toPairs (PgTag v
v) = [Text -> Key
Key.fromText (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Symbol). (SingKind Symbol, SingI a) => Demote Symbol
demote @(NameSymNat sn)) Key -> t -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @t v
v]

instance
  (KnownSymNat sn, FromJSON tEff, Coercible t tEff)
  => FromJSONCols ann 'NonGenericCase '[ 'ColInfo sn tEff db fi ] (fld := t) where
    parseJSONCols :: Value -> Parser (fld := t)
parseJSONCols = [Char]
-> (Object -> Parser (fld := t)) -> Value -> Parser (fld := t)
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"record" ((Object -> Parser (fld := t)) -> Value -> Parser (fld := t))
-> (Object -> Parser (fld := t)) -> Value -> Parser (fld := t)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup (Text -> Key
Key.fromText Text
Demote Symbol
keyTxt) Object
obj of
        Maybe Value
Nothing -> [Char] -> Parser (fld := t)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"missing key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
Demote Symbol
keyTxt)
        Just Value
v  -> tEff -> fld := t
forall a b. Coercible a b => a -> b
coerce (tEff -> fld := t) -> Parser tEff -> Parser (fld := t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON @tEff Value
v        -- eff :: tEff
      where
        keyTxt :: Demote Symbol
keyTxt = forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Symbol). (SingKind Symbol, SingI a) => Demote Symbol
demote @(NameSymNat sn)

instance
  ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b
  , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols
  , ToJSONCols ann ca colsA a, ToJSONCols ann cb colsB b )
  => ToJSONCols ann 'NonGenericCase cols (a :. b) where
    toPairs :: (a :. b) -> [(Key, Value)]
toPairs (a
a :. b
b) = forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToJSONCols ann colsCase cols r =>
r -> [(Key, Value)]
toPairs @ann @ca @colsA a
a [(Key, Value)] -> [(Key, Value)] -> [(Key, Value)]
forall a. Semigroup a => a -> a -> a
<> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToJSONCols ann colsCase cols r =>
r -> [(Key, Value)]
toPairs @ann @cb @colsB b
b

instance
  ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b
  , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols
  , FromJSONCols ann ca colsA a, FromJSONCols ann cb colsB b)
  => FromJSONCols ann 'NonGenericCase cols (a :. b) where
    parseJSONCols :: Value -> Parser (a :. b)
parseJSONCols Value
v =
      a -> b -> a :. b
forall h t. h -> t -> h :. t
(:.) (a -> b -> a :. b) -> Parser a -> Parser (b -> a :. b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromJSONCols ann colsCase cols r =>
Value -> Parser r
parseJSONCols @ann @ca @colsA Value
v Parser (b -> a :. b) -> Parser b -> Parser (a :. b)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromJSONCols ann colsCase cols r =>
Value -> Parser r
parseJSONCols @ann @cb @colsB Value
v

--------------------------------------------------------------------------------
-- Generic
-----------------------------------------------------------------------------
class GToJSONCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where
  gToPairs :: rep x -> [Pair]

class GFromJSONCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where
  gParseJSONCols :: Value -> Parser (rep x)

instance
  (Generic r, GToJSONCols ann cols (Rep r))
  => ToJSONCols ann 'GenericCase cols r where
    toPairs :: r -> [(Key, Value)]
toPairs r
r = forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToJSONCols ann cols rep =>
rep x -> [(Key, Value)]
gToPairs @ann @cols (r -> Rep r (ZonkAny 3)
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
from r
r)

instance
  (Generic r, GFromJSONCols ann cols (Rep r))
  => FromJSONCols ann 'GenericCase cols r where
    parseJSONCols :: Value -> Parser r
parseJSONCols = (Rep r (ZonkAny 2) -> r) -> Parser (Rep r (ZonkAny 2)) -> Parser r
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep r (ZonkAny 2) -> r
forall a x. Generic a => Rep a x -> a
forall x. Rep r x -> r
to (Parser (Rep r (ZonkAny 2)) -> Parser r)
-> (Value -> Parser (Rep r (ZonkAny 2))) -> Value -> Parser r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromJSONCols ann cols rep =>
Value -> Parser (rep x)
gParseJSONCols @ann @cols

-- D1/C1
instance GToJSONCols ann cols flds
  => GToJSONCols ann cols (D1 d (C1 c flds)) where
    gToPairs :: forall x. D1 d (C1 c flds) x -> [(Key, Value)]
gToPairs (M1 (M1 flds x
x)) = forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToJSONCols ann cols rep =>
rep x -> [(Key, Value)]
gToPairs @ann @cols flds x
x

instance GFromJSONCols ann cols flds
  => GFromJSONCols ann cols (D1 d (C1 c flds)) where
    gParseJSONCols :: forall x. Value -> Parser (D1 d (C1 c flds) x)
gParseJSONCols = (flds x -> D1 d (C1 c flds) x)
-> Parser (flds x) -> Parser (D1 d (C1 c flds) x)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (C1 c flds x -> D1 d (C1 c flds) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (C1 c flds x -> D1 d (C1 c flds) x)
-> (flds x -> C1 c flds x) -> flds x -> D1 d (C1 c flds) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. flds x -> C1 c flds x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) (Parser (flds x) -> Parser (D1 d (C1 c flds) x))
-> (Value -> Parser (flds x))
-> Value
-> Parser (D1 d (C1 c flds) x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromJSONCols ann cols rep =>
Value -> Parser (rep x)
gParseJSONCols @ann @cols

-- (:*:)
instance
  ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols
  , GToJSONCols ann colsA a, GToJSONCols ann colsB b )
  => GToJSONCols ann cols (a :*: b) where
    gToPairs :: forall x. (:*:) a b x -> [(Key, Value)]
gToPairs (a x
a :*: b x
b) = forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToJSONCols ann cols rep =>
rep x -> [(Key, Value)]
gToPairs @ann @colsA a x
a [(Key, Value)] -> [(Key, Value)] -> [(Key, Value)]
forall a. Semigroup a => a -> a -> a
<> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToJSONCols ann cols rep =>
rep x -> [(Key, Value)]
gToPairs @ann @colsB b x
b

instance
  ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols
  , GFromJSONCols ann colsA a, GFromJSONCols ann colsB b )
  => GFromJSONCols ann cols (a :*: b) where
    gParseJSONCols :: forall x. Value -> Parser ((:*:) a b x)
gParseJSONCols Value
v =
      a x -> b x -> (:*:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a x -> b x -> (:*:) a b x)
-> Parser (a x) -> Parser (b x -> (:*:) a b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromJSONCols ann cols rep =>
Value -> Parser (rep x)
gParseJSONCols @ann @colsA Value
v Parser (b x -> (:*:) a b x) -> Parser (b x) -> Parser ((:*:) a b x)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromJSONCols ann cols rep =>
Value -> Parser (rep x)
gParseJSONCols @ann @colsB Value
v

-- Rec0
instance (ToJSONCols ann 'NonGenericCase cols (fld := t))
  => GToJSONCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t))
  where
    gToPairs :: forall x.
S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x -> [(Key, Value)]
gToPairs (M1 (K1 t
v)) = forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToJSONCols ann colsCase cols r =>
r -> [(Key, Value)]
toPairs @ann @'NonGenericCase @cols (fld t -> fld := t
forall (a :: Symbol) -> t -> a := t
forall {k} b. forall (a :: k) -> b -> a := b
=: t
v)

instance (FromJSONCols ann 'NonGenericCase cols (fld := t))
  => GFromJSONCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) where
    gParseJSONCols :: forall x.
Value -> Parser (S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x)
gParseJSONCols = ((fld := t) -> S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x)
-> Parser (fld := t)
-> Parser (S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rec0 t x -> S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 t x -> S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x)
-> ((fld := t) -> Rec0 t x)
-> (fld := t)
-> S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rec0 t x
forall k i c (p :: k). c -> K1 i c p
K1 (t -> Rec0 t x) -> ((fld := t) -> t) -> (fld := t) -> Rec0 t x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (fld := t) -> t
forall {k} (s :: k) t. PgTag s t -> t
unPgTag)
      (Parser (fld := t)
 -> Parser (S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x))
-> (Value -> Parser (fld := t))
-> Value
-> Parser (S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromJSONCols ann colsCase cols r =>
Value -> Parser r
parseJSONCols @ann @'NonGenericCase @cols @(fld := t)

--------------------------------------------------------------------------------
-- ToRow / FromRow for PgTag ann r
--------------------------------------------------------------------------------
instance ToJSON (PgTag ann r) => ToField (PgTag (ann :: Ann) r) where
  toField :: PgTag ann r -> Action
toField = PgTag ann r -> Action
forall a. ToJSON a => a -> Action
toJSONField

instance ToJSON (PgTag ann r) => ToField [PgTag (ann :: Ann) r] where
  toField :: [PgTag ann r] -> Action
toField = [PgTag ann r] -> Action
forall a. ToJSON a => a -> Action
toJSONField

instance (FromJSON (PgTag ann r), Typeable ann, Typeable r)
  => FromField (PgTag (ann :: Ann) r) where
    fromField :: FieldParser (PgTag ann r)
fromField = FieldParser (PgTag ann r)
forall a. (FromJSON a, Typeable a) => FieldParser a
fromJSONField

instance (FromJSON (PgTag ann r), Typeable ann, Typeable r)
  => FromField [PgTag (ann :: Ann) r] where
    fromField :: FieldParser [PgTag ann r]
fromField = FieldParser [PgTag ann r]
forall a. (FromJSON a, Typeable a) => FieldParser a
fromJSONField

--------------------------------------------------------------------------------
-- ToRow / FromRow for PgTag ann r
--------------------------------------------------------------------------------
instance
  (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, ToRowCols ann colsCase cols r)
  => ToRow (PgTag ann r) where
    toRow :: PgTag ann r -> [Action]
toRow (PgTag r
r) = forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToRowCols ann colsCase cols r =>
r -> [Action]
toRowCols @ann @colsCase @cols r
r

instance
  (cols ~ Cols ann r, colsCase ~ ColsCaseOf r, FromRowCols ann colsCase cols r)
  => FromRow (PgTag ann r) where
    fromRow :: RowParser (PgTag ann r)
fromRow = r -> PgTag ann r
forall {k} (s :: k) t. t -> PgTag s t
PgTag (r -> PgTag ann r) -> RowParser r -> RowParser (PgTag ann r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromRowCols ann colsCase cols r =>
RowParser r
fromRowCols @ann @colsCase @cols

-- >>> type AnnRel = 'Ann RenamerId PgCatalog (PGC "pg_constraint")
-- >>> (r1 :: [PgTag AnnRel ( ("conkey" := Int16))]) <- query_ conn "select 1::int2"
-- >>> r1
-- [PgTag {unPgTag = PgTag {unPgTag = 1}}]

class ToRowCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r
  where
    toRowCols :: r -> [Action]

class FromRowCols (ann :: Ann) (colsCase :: ColsCase) (cols :: [ColInfo NameNSK]) r
  where
    fromRowCols :: RowParser r

--------------------------------------------------------------------------------
-- NonGeneric: (:=) and (:.)
--------------------------------------------------------------------------------
instance ToRowCols ann 'NonGenericCase '[] (fld := ()) where
  toRowCols :: (fld := ()) -> [Action]
toRowCols fld := ()
_ = []

instance FromRowCols ann 'NonGenericCase '[] (fld := ()) where
  fromRowCols :: RowParser (fld := ())
fromRowCols = (fld := ()) -> RowParser (fld := ())
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> fld := ()
forall {k} (s :: k) t. t -> PgTag s t
PgTag ())

instance (KnownSymNat sn, ToField t, Coercible v t)
  => ToRowCols ann 'NonGenericCase '[ 'ColInfo sn t db fi ] (fld := v) where
    toRowCols :: (fld := v) -> [Action]
toRowCols (PgTag v
v) = [t -> Action
forall a. ToField a => a -> Action
toField (forall a b. Coercible a b => a -> b
forall a b. Coercible a b => a -> b
coerce @_ @t v
v)]

instance (FromField tEff, Coercible t tEff)
  => FromRowCols ann 'NonGenericCase '[ 'ColInfo sn tEff db fi ] (fld := t) where
    fromRowCols :: RowParser (fld := t)
fromRowCols = tEff -> fld := t
forall a b. Coercible a b => a -> b
coerce (tEff -> fld := t) -> RowParser tEff -> RowParser (fld := t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromField a => RowParser a
field @tEff

instance
  ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b
  , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols
  , ToRowCols ann ca colsA a, ToRowCols ann cb colsB b )
  => ToRowCols ann 'NonGenericCase cols (a :. b) where
  toRowCols :: (a :. b) -> [Action]
toRowCols (a
a :. b
b) = forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToRowCols ann colsCase cols r =>
r -> [Action]
toRowCols @ann @ca @colsA a
a [Action] -> [Action] -> [Action]
forall a. Semigroup a => a -> a -> a
<> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToRowCols ann colsCase cols r =>
r -> [Action]
toRowCols @ann @cb @colsB b
b

instance
  ( ca ~ ColsCaseOf a, cb ~ ColsCaseOf b
  , '(colsA, colsB) ~ SplitAt (Length (Cols ann a)) cols
  , FromRowCols ann ca colsA a, FromRowCols ann cb colsB b )
  => FromRowCols ann 'NonGenericCase cols (a :. b) where
  fromRowCols :: RowParser (a :. b)
fromRowCols = a -> b -> a :. b
forall h t. h -> t -> h :. t
(:.) (a -> b -> a :. b) -> RowParser a -> RowParser (b -> a :. b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromRowCols ann colsCase cols r =>
RowParser r
fromRowCols @ann @ca @colsA RowParser (b -> a :. b) -> RowParser b -> RowParser (a :. b)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromRowCols ann colsCase cols r =>
RowParser r
fromRowCols @ann @cb @colsB

--------------------------------------------------------------------------------
-- Generic: through Rep r
--------------------------------------------------------------------------------

class GToRowCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where
  gToRowCols :: rep x -> [Action]

class GFromRowCols (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: Type -> Type) where
  gFromRowCols :: RowParser (rep x)

instance (Generic r, GToRowCols ann cols (Rep r))
  => ToRowCols (ann :: Ann) 'GenericCase cols r where
    toRowCols :: r -> [Action]
toRowCols r
r = forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToRowCols ann cols rep =>
rep x -> [Action]
gToRowCols @ann @cols (r -> Rep r (ZonkAny 1)
forall x. r -> Rep r x
forall a x. Generic a => a -> Rep a x
from r
r)

instance (Generic r, GFromRowCols ann cols (Rep r))
  => FromRowCols ann 'GenericCase cols r where
    fromRowCols :: RowParser r
fromRowCols = Rep r (ZonkAny 0) -> r
forall a x. Generic a => Rep a x -> a
forall x. Rep r x -> r
to (Rep r (ZonkAny 0) -> r)
-> RowParser (Rep r (ZonkAny 0)) -> RowParser r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromRowCols ann cols rep =>
RowParser (rep x)
gFromRowCols @ann @cols

instance GToRowCols ann cols flds
  => GToRowCols ann cols (D1 d (C1 c flds)) where
    gToRowCols :: forall x. D1 d (C1 c flds) x -> [Action]
gToRowCols (M1 (M1 flds x
x)) = forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToRowCols ann cols rep =>
rep x -> [Action]
gToRowCols @ann @cols flds x
x

instance GFromRowCols ann cols flds
  => GFromRowCols ann cols (D1 d (C1 c flds)) where
    gFromRowCols :: forall x. RowParser (D1 d (C1 c flds) x)
gFromRowCols = (flds x -> D1 d (C1 c flds) x)
-> RowParser (flds x) -> RowParser (D1 d (C1 c flds) x)
forall a b. (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (C1 c flds x -> D1 d (C1 c flds) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (C1 c flds x -> D1 d (C1 c flds) x)
-> (flds x -> C1 c flds x) -> flds x -> D1 d (C1 c flds) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. flds x -> C1 c flds x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1) (forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromRowCols ann cols rep =>
RowParser (rep x)
gFromRowCols @ann @cols)

instance
  ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols
  , GToRowCols   ann colsA a, GToRowCols   ann colsB b )
  => GToRowCols ann cols (a :*: b) where
    gToRowCols :: forall x. (:*:) a b x -> [Action]
gToRowCols (a x
a :*: b x
b) = forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToRowCols ann cols rep =>
rep x -> [Action]
gToRowCols @ann @colsA a x
a [Action] -> [Action] -> [Action]
forall a. Semigroup a => a -> a -> a
<> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GToRowCols ann cols rep =>
rep x -> [Action]
gToRowCols @ann @colsB b x
b

instance
  ( '(colsA, colsB) ~ SplitAt (Length (GCols ann a)) cols
  , GFromRowCols ann colsA a, GFromRowCols ann colsB b )
  => GFromRowCols ann cols (a :*: b) where
    gFromRowCols :: forall x. RowParser ((:*:) a b x)
gFromRowCols = a x -> b x -> (:*:) a b x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a x -> b x -> (:*:) a b x)
-> RowParser (a x) -> RowParser (b x -> (:*:) a b x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromRowCols ann cols rep =>
RowParser (rep x)
gFromRowCols @ann @colsA RowParser (b x -> (:*:) a b x)
-> RowParser (b x) -> RowParser ((:*:) a b x)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ann :: Ann) (cols :: [ColInfo NameNSK]) (rep :: * -> *) x.
GFromRowCols ann cols rep =>
RowParser (rep x)
gFromRowCols @ann @colsB

instance ToRowCols ann 'NonGenericCase cols (fld := t)
  => GToRowCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) where
    gToRowCols :: forall x. S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x -> [Action]
gToRowCols (M1 (K1 t
v)) = forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
ToRowCols ann colsCase cols r =>
r -> [Action]
toRowCols @ann @'NonGenericCase @cols (fld t -> fld := t
forall (a :: Symbol) -> t -> a := t
forall {k} b. forall (a :: k) -> b -> a := b
=: t
v)

instance
  FromRowCols ann 'NonGenericCase cols (fld := t)
  => GFromRowCols ann cols (S1 (MetaSel ('Just fld) u v w) (Rec0 t)) where
    gFromRowCols :: forall x. RowParser (S1 ('MetaSel ('Just fld) u v w) (Rec0 t) x)
gFromRowCols = Rec0 t x -> M1 S ('MetaSel ('Just fld) u v w) (Rec0 t) x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Rec0 t x -> M1 S ('MetaSel ('Just fld) u v w) (Rec0 t) x)
-> ((fld := t) -> Rec0 t x)
-> (fld := t)
-> M1 S ('MetaSel ('Just fld) u v w) (Rec0 t) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rec0 t x
forall k i c (p :: k). c -> K1 i c p
K1 (t -> Rec0 t x) -> ((fld := t) -> t) -> (fld := t) -> Rec0 t x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (fld := t) -> t
forall {k} (s :: k) t. PgTag s t -> t
unPgTag
      ((fld := t) -> M1 S ('MetaSel ('Just fld) u v w) (Rec0 t) x)
-> RowParser (fld := t)
-> RowParser (M1 S ('MetaSel ('Just fld) u v w) (Rec0 t) x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ann :: Ann) (colsCase :: ColsCase)
       (cols :: [ColInfo NameNSK]) r.
FromRowCols ann colsCase cols r =>
RowParser r
fromRowCols @ann @'NonGenericCase @cols @(fld := t)

--------------------------------------------------------------------------------
-- CRecInfo
--------------------------------------------------------------------------------

data FieldInfo s = FieldInfo
  { forall s. FieldInfo s -> s
fieldName   :: s
  , forall s. FieldInfo s -> s
fieldDbName :: s
  , forall s. FieldInfo s -> RecField' s (RecordInfo s)
fieldKind   :: RecField' s (RecordInfo s) }
  deriving Int -> FieldInfo s -> [Char] -> [Char]
[FieldInfo s] -> [Char] -> [Char]
FieldInfo s -> [Char]
(Int -> FieldInfo s -> [Char] -> [Char])
-> (FieldInfo s -> [Char])
-> ([FieldInfo s] -> [Char] -> [Char])
-> Show (FieldInfo s)
forall s. Show s => Int -> FieldInfo s -> [Char] -> [Char]
forall s. Show s => [FieldInfo s] -> [Char] -> [Char]
forall s. Show s => FieldInfo s -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall s. Show s => Int -> FieldInfo s -> [Char] -> [Char]
showsPrec :: Int -> FieldInfo s -> [Char] -> [Char]
$cshow :: forall s. Show s => FieldInfo s -> [Char]
show :: FieldInfo s -> [Char]
$cshowList :: forall s. Show s => [FieldInfo s] -> [Char] -> [Char]
showList :: [FieldInfo s] -> [Char] -> [Char]
Show

data RecordInfo s   = RecordInfo
  { forall s. RecordInfo s -> NameNS' s
tabName :: NameNS' s
  , forall s. RecordInfo s -> [FieldInfo s]
fields  :: [FieldInfo s] }
  deriving Int -> RecordInfo s -> [Char] -> [Char]
[RecordInfo s] -> [Char] -> [Char]
RecordInfo s -> [Char]
(Int -> RecordInfo s -> [Char] -> [Char])
-> (RecordInfo s -> [Char])
-> ([RecordInfo s] -> [Char] -> [Char])
-> Show (RecordInfo s)
forall s. Show s => Int -> RecordInfo s -> [Char] -> [Char]
forall s. Show s => [RecordInfo s] -> [Char] -> [Char]
forall s. Show s => RecordInfo s -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall s. Show s => Int -> RecordInfo s -> [Char] -> [Char]
showsPrec :: Int -> RecordInfo s -> [Char] -> [Char]
$cshow :: forall s. Show s => RecordInfo s -> [Char]
show :: RecordInfo s -> [Char]
$cshowList :: forall s. Show s => [RecordInfo s] -> [Char] -> [Char]
showList :: [RecordInfo s] -> [Char] -> [Char]
Show

class CRecInfo (ann :: Ann) (r :: Type) where
  getRecordInfo :: RecordInfo T.Text

class CRecInfoCols (ann :: Ann) (cols :: [ColInfo NameNSK]) where
  getFields :: [FieldInfo T.Text]

class CFldInfo (ann :: Ann) (fld :: RecField' Symbol NameNSK) t where
  getFldInfo :: RecField (RecordInfo T.Text)

-- instance (ann ~ 'Ann ren sch tab, SingI tab) => CRecInfo ann () where
--   getRecordInfo = RecordInfo (demote @tab) []

instance
  (ann ~ 'Ann ren sch d tab, SingI tab, cols ~ Cols ann r, CRecInfoCols ann cols)
  => CRecInfo ann r where
  getRecordInfo :: RecordInfo Text
getRecordInfo = NameNS' Text -> [FieldInfo Text] -> RecordInfo Text
forall s. NameNS' s -> [FieldInfo s] -> RecordInfo s
RecordInfo (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: NameNSK).
(SingKind NameNSK, SingI a) =>
Demote NameNSK
demote @tab) (forall (ann :: Ann) (cols :: [ColInfo NameNSK]).
CRecInfoCols ann cols =>
[FieldInfo Text]
getFields @ann @cols)

instance CRecInfoCols ann '[] where getFields :: [FieldInfo Text]
getFields = []

instance
  (KnownSymNat sn, KnownSymbol db, CFldInfo ann fi t, CRecInfoCols ann cols)
  => CRecInfoCols ann ('ColInfo sn t db fi ': cols) where
  getFields :: [FieldInfo Text]
getFields = FieldInfo
    { fieldName :: Text
fieldName   = forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Symbol). (SingKind Symbol, SingI a) => Demote Symbol
demote @(NameSymNat sn)
    , fieldDbName :: Text
fieldDbName = forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Symbol). (SingKind Symbol, SingI a) => Demote Symbol
demote @db
    , fieldKind :: RecField' Text (RecordInfo Text)
fieldKind   = forall {k} (ann :: Ann) (fld :: RecField' Symbol NameNSK) (t :: k).
CFldInfo ann fld t =>
RecField' Text (RecordInfo Text)
forall (ann :: Ann) (fld :: RecField' Symbol NameNSK) t.
CFldInfo ann fld t =>
RecField' Text (RecordInfo Text)
getFldInfo @ann @fi @t } FieldInfo Text -> [FieldInfo Text] -> [FieldInfo Text]
forall a. a -> [a] -> [a]
: forall (ann :: Ann) (cols :: [ColInfo NameNSK]).
CRecInfoCols ann cols =>
[FieldInfo Text]
getFields @ann @cols

instance ToStar fd => CFldInfo ann ('RFPlain fd) t where
  getFldInfo :: RecField' Text (RecordInfo Text)
getFldInfo = FldDef' Text -> RecField' Text (RecordInfo Text)
forall s p. FldDef' s -> RecField' s p
RFPlain (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: FldDef' Symbol).
(SingKind (FldDef' Symbol), SingI a) =>
Demote (FldDef' Symbol)
demote @fd)

instance (ToStar fd, ToStar af, ToStar b) =>
  CFldInfo ann ('RFAggr fd af b) t where
  getFldInfo :: RecField' Text (RecordInfo Text)
getFldInfo = FldDef' Text -> AggrFun -> Bool -> RecField' Text (RecordInfo Text)
forall s p. FldDef' s -> AggrFun -> Bool -> RecField' s p
RFAggr (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: FldDef' Symbol).
(SingKind (FldDef' Symbol), SingI a) =>
Demote (FldDef' Symbol)
demote @fd) (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: AggrFun).
(SingKind AggrFun, SingI a) =>
Demote AggrFun
demote @af) (forall (a :: Bool). (SingKind Bool, SingI a) => Demote Bool
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @b)

type family AnnRefTabDepth (ann :: Ann) refTab :: Ann where
  AnnRefTabDepth ('Ann ren sch d tab) refTab =
    'Ann ren sch (DecDepth ('Ann ren sch d tab)) refTab

instance (CRecInfo ann' r, ToStar refs, ann' ~ AnnRefTabDepth ann fromTab)
  => CFldInfo ann ('RFToHere fromTab refs) [PgTag ann' r] where
  getFldInfo :: RecField' Text (RecordInfo Text)
getFldInfo = RecordInfo Text -> [Ref' Text] -> RecField' Text (RecordInfo Text)
forall s p. p -> [Ref' s] -> RecField' s p
RFToHere (forall (ann :: Ann) r. CRecInfo ann r => RecordInfo Text
getRecordInfo @ann' @r) (forall (a :: [Ref' Symbol]).
(SingKind [Ref' Symbol], SingI a) =>
Demote [Ref' Symbol]
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @refs)

instance (CRecInfo ann' r, ToStar refs, ann' ~ AnnRefTabDepth ann toTab)
  => CFldInfo ann ('RFFromHere toTab refs) (Maybe (PgTag ann' r)) where
  getFldInfo :: RecField' Text (RecordInfo Text)
getFldInfo = RecordInfo Text -> [Ref' Text] -> RecField' Text (RecordInfo Text)
forall s p. p -> [Ref' s] -> RecField' s p
RFFromHere (forall (ann :: Ann) r. CRecInfo ann r => RecordInfo Text
getRecordInfo @ann' @r) (forall (a :: [Ref' Symbol]).
(SingKind [Ref' Symbol], SingI a) =>
Demote [Ref' Symbol]
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @refs)

instance (CRecInfo ann' r, ToStar refs, ann' ~ AnnRefTabDepth ann toTab)
  => CFldInfo ann ('RFFromHere toTab refs) (PgTag ann' r) where
  getFldInfo :: RecField' Text (RecordInfo Text)
getFldInfo = RecordInfo Text -> [Ref' Text] -> RecField' Text (RecordInfo Text)
forall s p. p -> [Ref' s] -> RecField' s p
RFFromHere (forall (ann :: Ann) r. CRecInfo ann r => RecordInfo Text
getRecordInfo @ann' @r) (forall (a :: [Ref' Symbol]).
(SingKind [Ref' Symbol], SingI a) =>
Demote [Ref' Symbol]
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @refs)

--------------------------------------------------------------------------------
-- Helpers over Cols ann r
--------------------------------------------------------------------------------

type family ColDbName (c :: ColInfo p) :: Symbol where
  ColDbName ('ColInfo '(fld, idx) t db fi) = db

type family ColsDbNames (cols :: [ColInfo p]) :: [Symbol] where
  ColsDbNames '[]       = '[]
  ColsDbNames (c ': cs) = ColDbName c ': ColsDbNames cs

--------------------------------------------------------------------------------
-- Plain fields (without relation fields)
--------------------------------------------------------------------------------

type family IsPlainRecField (fi :: RecField' Symbol NameNSK) :: Bool where
  IsPlainRecField ('RFToHere tab rs)   = 'False
  IsPlainRecField ('RFFromHere tab rs) = 'False
  IsPlainRecField ('RFSelfRef tab rs)  = 'False
  IsPlainRecField fi        = 'True

type family AllPlainCols (cols :: [ColInfo NameNSK]) :: Bool where
  AllPlainCols '[] = 'True
  AllPlainCols ('ColInfo sn t db fi ': cs) = IsPlainRecField fi && AllPlainCols cs

-- | All fields are plain (no RFToHere/RFFromHere)
type family AllPlain (ann :: Ann) (r :: Type) :: Constraint where
  AllPlain ann r = Assert (AllPlainCols (Cols ann r))
    (TypeError
      (  Text "Not all fields in record are 'plain' (no relations allowed)."
      :$$: Text "Ann:   " :<>: ShowType ann
      :$$: Text "Type:  " :<>: ShowType r
      :$$: Text "Cols:  " :<>: ShowType (Cols ann r) ))

--------------------------------------------------------------------------------
-- Type-level RecordInfo for Ann
--------------------------------------------------------------------------------
-- | Decrease relation-walk depth kept in 'Ann'.
-- When depth is exhausted, fail with a detailed type error instead of
-- potentially diverging in recursive type families/instances.
type family DecDepth (ann :: Ann) :: Nat where
  DecDepth ('Ann ren sch 0 tab) = TypeError
    (  Text "pg-schema: relation walk depth limit reached."
    :$$: Text ""
    :$$: Text "Ann:   " :<>: ShowType ('Ann ren sch 0 tab)
    :$$: Text "Table: " :<>: ShowType tab
    :$$: Text ""
    :$$: Text "Likely reason:"
    :$$: Text "  Recursive/self-referential tree (SelfRef or cycle) is deeper"
    :$$: Text "  than annDepth in your Ann."
    :$$: Text ""
    :$$: Text "How to fix:"
    :$$: Text "  1) Increase annDepth in Ann;"
    :$$: Text "  2) Reduce recursion depth in selected/inserted shape;"
    :$$: Text "  3) For true graph cycles, use manual SQL." )
  DecDepth ('Ann _ _ d _) = d - 1

-- Type-level analogue of CFldInfo: take DB-level RecFieldK and Haskell type of field t
-- and build RecField' Symbol (RecordInfo Symbol) with TRecordInfo for children.
type family TFldInfo (ann :: Ann) (fi :: RecField' Symbol NameNSK) t
  :: RecField' Symbol (RecordInfo Symbol) where
  TFldInfo ann ('RFPlain fd) t      = 'RFPlain fd
  TFldInfo ann ('RFAggr  fd af b) t = 'RFAggr fd af b
  TFldInfo ann ('RFEmpty s)    t    = 'RFEmpty s
  TFldInfo ('Ann ren sch d tab) ('RFToHere (toTab :: NameNSK) refs)
    [PgTag ('Ann ren sch d' toTab) rChild] =
    'RFToHere ('RecordInfo toTab (TRecordInfo ('Ann ren sch d' toTab) rChild)) refs
  TFldInfo ('Ann ren sch d tab) ('RFFromHere (toTab :: NameNSK) refs)
    (Maybe (PgTag ('Ann ren sch d' toTab) rChild)) =
    'RFFromHere ('RecordInfo toTab (TRecordInfo ('Ann ren sch d' toTab) rChild)) refs
  TFldInfo ('Ann ren sch d tab) ('RFFromHere (toTab :: NameNSK) refs)
    (PgTag ('Ann ren sch d' toTab) rChild) =
    'RFFromHere ('RecordInfo toTab (TRecordInfo ('Ann ren sch d' toTab) rChild)) refs
  TFldInfo ann fi t = TypeError
    (  Text "TFldInfo: unsupported RecField for Ann."
    :$$: Text "  Ann: " :<>: ShowType ann
    :$$: Text "  RecField: " :<>: ShowType fi
    :$$: Text "  Haskell type: " :<>: ShowType t
    :$$: Text ""
    :$$: Text "Most likely TDBFieldInfo / ColFI produced a constructor"
    :$$: Text "that TFldInfo does not know how to map into RecordInfo." )

type family TRecordInfoCols (ann  :: Ann) (cols :: [ColInfo NameNSK]) :: [FieldInfo Symbol] where
  TRecordInfoCols ann '[] = '[]
  TRecordInfoCols ann ('ColInfo sn t db fi ': cs) =
    'FieldInfo (NameSymNat sn) db (TFldInfo ann fi t) ': TRecordInfoCols ann cs

type family TRecordInfo (ann :: Ann) (r :: Type) :: [FieldInfo Symbol] where
  TRecordInfo ann r = TRecordInfoCols ann (Cols ann r)

--------------------------------------------------------------------------------
-- Node-level checks for Mandatory / PK (analogue of CheckNodeAll*)
--------------------------------------------------------------------------------

-- | One-table check that all mandatory fields are present
-- rs: list of columns that are already "covered" (including those that come from Reference)
type family CheckAllMandatory (ann :: Ann) (rs :: [Symbol]) :: Constraint where
  CheckAllMandatory ('Ann ren sch d tab) rs = TE.Assert
    (SP.Null (RestMandatory sch tab rs))
    (TypeError
      (  Text "We can't insert data because not all mandatory fields are present."
      :$$: Text "Table: " :<>: ShowType tab
      :$$: Text "Missing mandatory fields: " :<>: ShowType (RestMandatory sch tab rs) ))

-- | One-table check that all mandatory fields are present
-- or all PK fields are present
type family CheckAllMandatoryOrHasPK (ann :: Ann) (rs :: [Symbol]) :: Constraint where
  CheckAllMandatoryOrHasPK ('Ann ren sch d tab) rs = TE.Assert
    ( SP.Null (RestMandatory sch tab rs)
      || SP.Null (RestPK sch tab rs) )
    (TypeError
      (  Text "We can't upsert data because for table " :<>: ShowType tab
      :$$: Text "either not all mandatory fields or not all PK fields are present."
      :$$: Text "Missing mandatory fields: " :<>: ShowType (RestMandatory sch tab rs)
      :$$: Text "Missing PK fields: " :<>: ShowType (RestPK sch tab rs) ))

genDefunSymbols [ ''CheckAllMandatory, ''CheckAllMandatoryOrHasPK]

--------------------------------------------------------------------------------
-- Recursive AllMandatory / PK for tree (JSON insert / upsert)
--------------------------------------------------------------------------------
type family WalkLevelAnn
  (check :: Ann ~> [Symbol] ~> Constraint)
  (ann :: Ann) (fis :: [FieldInfo Symbol]) (rs :: [Symbol]) :: Constraint where
  WalkLevelAnn check ann '[] rs = SP.Apply (SP.Apply check ann) rs
  WalkLevelAnn check ann ('FieldInfo name db ('RFPlain fd) ': xs) rs =
    WalkLevelAnn check ann xs (db ': rs)
  WalkLevelAnn check ('Ann ren sch d tab)
    ('FieldInfo _ _ ('RFToHere ('RecordInfo childTab childFIs) refs) ': xs) rs =
      ( WalkLevelAnn check ('Ann ren sch d childTab) childFIs (SP.Map1 FromNameSym0 refs)
      , WalkLevelAnn check ('Ann ren sch d tab) xs rs )
  WalkLevelAnn check ann (_ ': xs) rs = WalkLevelAnn check ann xs rs

type family AllMandatoryTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])
  :: Constraint where
  AllMandatoryTree ann [r] rFlds = AllMandatoryTree ann r rFlds
  AllMandatoryTree ann r rFlds =
    WalkLevelAnn CheckAllMandatorySym0 ann (TRecordInfo ann r) rFlds

type family AllMandatoryOrHasPKTree (ann :: Ann) (r :: Type) (rFlds :: [Symbol])
  :: Constraint where
  AllMandatoryOrHasPKTree ann [r] rFlds = AllMandatoryOrHasPKTree ann r rFlds
  AllMandatoryOrHasPKTree ann r rFlds =
    WalkLevelAnn CheckAllMandatoryOrHasPKSym0 ann (TRecordInfo ann r) rFlds

--------------------------------------------------------------------------------
-- Returning tree must be subtree of input tree (with path)
--------------------------------------------------------------------------------

type family Snoc (p :: [k]) (x :: k) :: [k] where
  Snoc '[] x = '[x]
  Snoc (a ': as) x = a ': Snoc as x

type family FindChildAt (path :: [Symbol]) (db :: Symbol)
  (fisIn :: [FieldInfo Symbol]) :: [FieldInfo Symbol] where
  FindChildAt path db '[] = TypeError
    (  Text "Returning tree is not a subtree of input tree."
    :$$: Text "At path: " :<>: ShowType path
    :$$: Text "Missing branch (db name): " :<>: ShowType db )
  FindChildAt _ db ('FieldInfo _ db ('RFToHere ('RecordInfo _ fis) _) ': xs) = fis
  FindChildAt _ db ('FieldInfo _ db ('RFFromHere ('RecordInfo _ fis) _) ': xs) = fis
  FindChildAt path db (_ ': xs) = FindChildAt path db xs

type family CheckSubtreeAt (path :: [Symbol]) (fisIn :: [FieldInfo Symbol])
  (fisOut :: [FieldInfo Symbol]) :: Constraint where
  CheckSubtreeAt path fisIn '[] = ()
  CheckSubtreeAt path fisIn
    ('FieldInfo _ db ('RFToHere ('RecordInfo _ childFIsOut) _) ': xs) =
      ( CheckSubtreeAt (Snoc path db) (FindChildAt path db fisIn) childFIsOut
      , CheckSubtreeAt path fisIn xs )
  CheckSubtreeAt path fisIn
    ('FieldInfo _ db ('RFFromHere ('RecordInfo _ childFIsOut) _) ': xs) =
      ( CheckSubtreeAt (Snoc path db) (FindChildAt path db fisIn) childFIsOut
      , CheckSubtreeAt path fisIn xs )
  CheckSubtreeAt path fisIn (_ ': xs) = CheckSubtreeAt path fisIn xs

-- | Check that returning tree is a subtree of input tree
type family ReturningIsSubtree (ann :: Ann) (rIn :: Type) (rOut :: Type) :: Constraint where
  ReturningIsSubtree ann rIn rOut =
    CheckSubtreeAt '[] (TRecordInfo ann rIn) (TRecordInfo ann rOut)