module Sqel.ReifyDd where

import Generics.SOP (I (I), NP (Nil, (:*)), tl)

import Sqel.Class.Mods (MaybeMod (maybeMod))
import Sqel.Codec (PrimColumn (pgType))
import Sqel.ColumnConstraints (ColumnConstraints, columnConstraints)
import Sqel.Data.Dd (Dd (Dd), DdK (DdK), DdStruct (DdComp, DdPrim), Struct (Comp, Prim))
import Sqel.Data.Mods (
  ArrayColumn (ArrayColumn),
  Mods (Mods),
  Newtype (Newtype),
  Nullable (Nullable),
  SetTableName,
  unSetTableName,
  )
import Sqel.Data.PgType (PgPrimName, pgColumnName)
import Sqel.Data.Sel (ReifySel (reifySel), SelW (SelWSymbol), TSelW (TSelW))
import qualified Sqel.Data.Term as Term
import Sqel.Data.Term (DdTerm (DdTerm), demoteComp, demoteInc)
import Sqel.SOP.Constraint (symbolText)

class ReifyPrimName a mods where
  reifyPrimName :: NP I mods -> PgPrimName

instance {-# overlappable #-} (
    ReifyPrimName a mods
  ) => ReifyPrimName a (p : mods) where
    reifyPrimName :: NP I (p : mods) -> PgPrimName
reifyPrimName = forall {k} (a :: k) (mods :: [*]).
ReifyPrimName a mods =>
NP I mods -> PgPrimName
reifyPrimName @a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
NP f (x : xs) -> NP f xs
tl

instance (
    PrimColumn a
  ) => ReifyPrimName a '[] where
    reifyPrimName :: NP I '[] -> PgPrimName
reifyPrimName NP I '[]
Nil = forall a. PrimColumn a => PgPrimName
pgType @a

instance (
    ReifyPrimName a mods
  ) => ReifyPrimName (Maybe a) (Nullable : mods) where
    reifyPrimName :: NP I (Nullable : mods) -> PgPrimName
reifyPrimName (I x
Nullable
Nullable :* NP I xs
mods) = forall {k} (a :: k) (mods :: [*]).
ReifyPrimName a mods =>
NP I mods -> PgPrimName
reifyPrimName @a NP I xs
mods

instance (
    ReifyPrimName a mods
  ) => ReifyPrimName (f a) (ArrayColumn f : mods) where
    reifyPrimName :: NP I (ArrayColumn f : mods) -> PgPrimName
reifyPrimName (I x
ArrayColumn f
ArrayColumn :* NP I xs
mods) = forall {k} (a :: k) (mods :: [*]).
ReifyPrimName a mods =>
NP I mods -> PgPrimName
reifyPrimName @a NP I xs
mods forall a. Semigroup a => a -> a -> a
<> PgPrimName
"[]"

instance (
    ReifyPrimName w mods
  ) => ReifyPrimName a (Newtype a w : mods) where
    reifyPrimName :: NP I (Newtype a w : mods) -> PgPrimName
reifyPrimName (I (Newtype a -> w
_ w -> a
_) :* NP I xs
mods) = forall {k} (a :: k) (mods :: [*]).
ReifyPrimName a mods =>
NP I mods -> PgPrimName
reifyPrimName @w NP I xs
mods

instance ReifyPrimName a (PgPrimName : mods) where
  reifyPrimName :: NP I (PgPrimName : mods) -> PgPrimName
reifyPrimName (I x
t :* NP I xs
_) = x
t

class ReifyDd s where
  reifyDd :: Dd s -> DdTerm

instance (
    ColumnConstraints mods,
    MaybeMod SetTableName mods,
    ReifyPrimName a mods,
    ReifySel sel name
  ) => ReifyDd ('DdK sel mods a 'Prim) where
    reifyDd :: Dd ('DdK sel mods a 'Prim) -> DdTerm
reifyDd (Dd SelW sel
sel mods :: Mods mods
mods@(Mods NP I mods
ms) DdStruct s1
DdPrim) =
      PgColumnName
-> Maybe PgTableName -> Bool -> [Sql] -> Struct -> DdTerm
DdTerm (Text -> PgColumnName
pgColumnName Text
name) (SetTableName -> PgTableName
unSetTableName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall p (ps :: [*]). MaybeMod p ps => Mods ps -> Maybe p
maybeMod Mods mods
mods) Bool
unique [Sql]
constraints (PgPrimName -> Struct
Term.Prim (forall {k} (a :: k) (mods :: [*]).
ReifyPrimName a mods =>
NP I mods -> PgPrimName
reifyPrimName @a NP I mods
ms))
      where
        (Bool
unique, [Sql]
constraints) = forall (mods :: [*]).
ColumnConstraints mods =>
Mods mods -> (Bool, [Sql])
columnConstraints Mods mods
mods
        name :: Text
name = forall (sel :: Sel) (name :: Symbol).
ReifySel sel name =>
SelW sel -> Text
reifySel SelW sel
sel

instance (
    ColumnConstraints mods,
    MaybeMod SetTableName mods,
    ReifyDdComp sub
  ) => ReifyDd ('DdK sel mods a ('Comp tsel c i sub)) where
    reifyDd :: Dd ('DdK sel mods a ('Comp tsel c i sub)) -> DdTerm
reifyDd (Dd SelW sel
sel Mods mods
mods (DdComp (TSelW (Proxy '(tpe, name)
Proxy :: Proxy '(tname, tpe))) DdSort c
c DdInc i
i NP Dd sub
sub)) =
      PgColumnName
-> Maybe PgTableName -> Bool -> [Sql] -> Struct -> DdTerm
DdTerm (Text -> PgColumnName
pgColumnName Text
name) (SetTableName -> PgTableName
unSetTableName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall p (ps :: [*]). MaybeMod p ps => Mods ps -> Maybe p
maybeMod Mods mods
mods) Bool
unique [Sql]
constraints Struct
struct
      where
        (Bool
unique, [Sql]
constraints) = forall (mods :: [*]).
ColumnConstraints mods =>
Mods mods -> (Bool, [Sql])
columnConstraints Mods mods
mods
        struct :: Struct
struct = Text -> Comp -> CompInc -> [DdTerm] -> Struct
Term.Comp Text
typeName (forall (c :: Comp). DdSort c -> Comp
demoteComp DdSort c
c) (forall (i :: CompInc). DdInc i -> CompInc
demoteInc DdInc i
i) (forall (s :: [DdK]). ReifyDdComp s => NP Dd s -> [DdTerm]
reifyDdComp NP Dd sub
sub)
        name :: Text
name = case SelW sel
sel of
          SelWSymbol (Proxy name
Proxy :: Proxy name) -> forall (name :: Symbol). KnownSymbol name => Text
symbolText @name
          SelW sel
_ -> forall (name :: Symbol). KnownSymbol name => Text
symbolText @tname
        typeName :: Text
typeName = forall (name :: Symbol). KnownSymbol name => Text
symbolText @tpe

-- TODO this is probably only necessary because of a bug in GHC that's fixed in master
class ReifyDdComp s where
  reifyDdComp :: NP Dd s -> [DdTerm]

instance ReifyDdComp '[] where
  reifyDdComp :: NP Dd '[] -> [DdTerm]
reifyDdComp NP Dd '[]
Nil = []

instance (
    ReifyDd s,
    ReifyDdComp ss
  ) => ReifyDdComp (s : ss) where
    reifyDdComp :: NP Dd (s : ss) -> [DdTerm]
reifyDdComp (Dd x
s :* NP Dd xs
ss) = forall (s :: DdK). ReifyDd s => Dd s -> DdTerm
reifyDd Dd x
s forall a. a -> [a] -> [a]
: forall (s :: [DdK]). ReifyDdComp s => NP Dd s -> [DdTerm]
reifyDdComp NP Dd xs
ss