module Sqel.PgType where

import Data.List.NonEmpty ((<|))
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Exon
import Exon (exon)
import Lens.Micro (_1, _2, _3, _4, (^.))
import Lens.Micro.Extras (view)
import Sqel.Class.MatchView (MatchProjection)
import Sqel.Data.Codec (Codec (Codec), FullCodec)
import Sqel.Data.Dd (Dd, DdK, DdType)
import Sqel.Data.PgType (
  ColumnType (ColumnComp, ColumnPrim),
  PgColumn (PgColumn),
  PgColumnName (PgColumnName),
  PgColumns (PgColumns),
  PgComposite (PgComposite),
  PgStructure (PgStructure),
  PgTable (PgTable),
  PgTypeRef,
  StructureType (StructureComp, StructurePrim),
  TableSelectors (TableSelectors),
  TableValues (TableValues),
  pgCompRef,
  )
import Sqel.Data.PgTypeName (PgTableName, pgCompName, pgTableName)
import qualified Sqel.Data.Projection as Projection
import Sqel.Data.Projection (Projection (Projection))
import Sqel.Data.ProjectionWitness (ProjectionWitness (ProjectionWitness))
import Sqel.Data.Selector (Selector (Selector))
import Sqel.Data.Sql (Sql (Sql), sql)
import qualified Sqel.Data.TableSchema as TableSchema
import Sqel.Data.TableSchema (TableSchema (TableSchema))
import Sqel.Data.Term (Comp, CompInc (Merge), DdTerm (DdTerm), Struct (Comp, Prim))
import Sqel.ReifyCodec (ReifyCodec (reifyCodec))
import Sqel.ReifyDd (ReifyDd (reifyDd))
import Sqel.SOP.Error (Quoted)
import Sqel.Sql.Prepared (dollar)
import Sqel.Text.Quote (dquote)
import Type.Errors (ErrorMessage)

pgColumn ::
  DdTerm ->
  ([PgColumn], [(PgColumnName, StructureType)], Map PgTypeRef PgComposite, [NonEmpty PgColumnName])
pgColumn :: DdTerm
-> ([PgColumn], [(PgColumnName, StructureType)],
    Map PgTypeRef PgComposite, [NonEmpty PgColumnName])
pgColumn = \case
  DdTerm PgColumnName
name Maybe PgTableName
_ Bool
unique [Sql]
constr (Prim PgPrimName
t) ->
    ([PgColumnName -> ColumnType -> PgColumn
PgColumn PgColumnName
name (PgPrimName -> Bool -> [Sql] -> ColumnType
ColumnPrim PgPrimName
t Bool
unique [Sql]
constr)], [(PgColumnName
name, PgPrimName -> Bool -> [Sql] -> StructureType
StructurePrim PgPrimName
t Bool
unique [Sql]
constr)], forall a. Monoid a => a
mempty, [forall (f :: * -> *) a. Applicative f => a -> f a
pure PgColumnName
name])
  DdTerm PgColumnName
name Maybe PgTableName
_ Bool
unique [Sql]
constr (Comp Text
typeName Comp
c CompInc
i [DdTerm]
sub) ->
    case Text
-> Comp
-> CompInc
-> [DdTerm]
-> (PgComposite, PgStructure, Map PgTypeRef PgComposite, Bool,
    [NonEmpty PgColumnName])
comp Text
typeName Comp
c CompInc
i [DdTerm]
sub of
      (compType :: PgComposite
compType@(PgComposite PgCompName
cname PgColumns
_), PgStructure
struct, Map PgTypeRef PgComposite
types, Bool
False, [NonEmpty PgColumnName]
sels) ->
        ([PgColumn]
colType, [(PgColumnName, StructureType)]
structType, forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PgTypeRef
ref PgComposite
compType Map PgTypeRef PgComposite
types, (PgColumnName
name forall a. a -> NonEmpty a -> NonEmpty a
<|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NonEmpty PgColumnName]
sels)
        where
          colType :: [PgColumn]
colType = [PgColumnName -> ColumnType -> PgColumn
PgColumn PgColumnName
name (PgTypeRef -> Bool -> [Sql] -> ColumnType
ColumnComp PgTypeRef
ref Bool
unique [Sql]
constr)]
          structType :: [(PgColumnName, StructureType)]
structType = [(PgColumnName
name, PgCompName -> PgStructure -> Bool -> [Sql] -> StructureType
StructureComp PgCompName
cname PgStructure
struct Bool
unique [Sql]
constr)]
          ref :: PgTypeRef
ref = PgCompName -> PgTypeRef
pgCompRef PgCompName
cname
      (PgComposite PgCompName
_ (PgColumns [PgColumn]
columns), PgStructure [(PgColumnName, StructureType)]
struct, Map PgTypeRef PgComposite
types, Bool
True, [NonEmpty PgColumnName]
sels) ->
        ([PgColumn]
columns, [(PgColumnName, StructureType)]
struct, Map PgTypeRef PgComposite
types, [NonEmpty PgColumnName]
sels)

comp ::
  Text ->
  Comp ->
  CompInc ->
  [DdTerm] ->
  (PgComposite, PgStructure, Map PgTypeRef PgComposite, Bool, [NonEmpty PgColumnName])
comp :: Text
-> Comp
-> CompInc
-> [DdTerm]
-> (PgComposite, PgStructure, Map PgTypeRef PgComposite, Bool,
    [NonEmpty PgColumnName])
comp Text
typeName Comp
_ CompInc
i [DdTerm]
sub =
  (PgComposite
compType, PgStructure
structType, forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall a s. Getting a s a -> s -> a
view forall s t a b. Field3 s t a b => Lens s t a b
_3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([PgColumn], [(PgColumnName, StructureType)],
  Map PgTypeRef PgComposite, [NonEmpty PgColumnName])]
cols), CompInc
i forall a. Eq a => a -> a -> Bool
== CompInc
Merge, forall a s. Getting a s a -> s -> a
view forall s t a b. Field4 s t a b => Lens s t a b
_4 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [([PgColumn], [(PgColumnName, StructureType)],
  Map PgTypeRef PgComposite, [NonEmpty PgColumnName])]
cols)
  where
    compType :: PgComposite
compType = PgCompName -> PgColumns -> PgComposite
PgComposite PgCompName
compName ([PgColumn] -> PgColumns
PgColumns (forall a s. Getting a s a -> s -> a
view forall s t a b. Field1 s t a b => Lens s t a b
_1 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [([PgColumn], [(PgColumnName, StructureType)],
  Map PgTypeRef PgComposite, [NonEmpty PgColumnName])]
cols))
    structType :: PgStructure
structType = [(PgColumnName, StructureType)] -> PgStructure
PgStructure (forall a s. Getting a s a -> s -> a
view forall s t a b. Field2 s t a b => Lens s t a b
_2 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [([PgColumn], [(PgColumnName, StructureType)],
  Map PgTypeRef PgComposite, [NonEmpty PgColumnName])]
cols)
    compName :: PgCompName
compName = Text -> PgCompName
pgCompName Text
typeName
    cols :: [([PgColumn], [(PgColumnName, StructureType)],
  Map PgTypeRef PgComposite, [NonEmpty PgColumnName])]
cols = DdTerm
-> ([PgColumn], [(PgColumnName, StructureType)],
    Map PgTypeRef PgComposite, [NonEmpty PgColumnName])
pgColumn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DdTerm]
sub

-- TODO this used to dquote the @names@ as well but it appears to fail for the sum index field
mkSelector :: NonEmpty PgColumnName -> Selector
mkSelector :: NonEmpty PgColumnName -> Selector
mkSelector =
  Sql -> Selector
Selector forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Sql
Sql forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    [PgColumnName Text
name] -> forall a. Exon a => a -> a
dquote Text
name
    PgColumnName
root :| [PgColumnName]
names -> [exon|(##{dquote root}).##{Text.intercalate "." (coerce names)}|]

-- TODO use CommaSep
mkValues :: PgStructure -> [Sql]
mkValues :: PgStructure -> [Sql]
mkValues (PgStructure [(PgColumnName, StructureType)]
base) =
  forall a b. (a, b) -> b
snd (forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {inner} {builder}.
(ExonBuilder inner builder, ExonString (SkipWs inner) builder,
 ExonAppend (SkipWs inner) builder, IsString inner, Monoid inner) =>
Int -> (PgColumnName, StructureType) -> (Int, inner)
mkCol (Int
1 :: Int) [(PgColumnName, StructureType)]
base)
  where
    mkCol :: Int -> (PgColumnName, StructureType) -> (Int, inner)
mkCol (Int
n :: Int) = \case
      (PgColumnName
_, StructurePrim PgPrimName
_ Bool
_ [Sql]
_) -> (Int
n forall a. Num a => a -> a -> a
+ Int
1, [sql|##{dollar n}|])
      (PgColumnName
_, StructureComp PgCompName
_ (PgStructure [(PgColumnName, StructureType)]
cols) Bool
_ [Sql]
_) ->
        (Int
newN, [sql|row(#{Exon.intercalate ", " sub})|])
        where
          (Int
newN, [inner]
sub) =
            forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL Int -> (PgColumnName, StructureType) -> (Int, inner)
mkCol Int
n [(PgColumnName, StructureType)]
cols

mkTable ::
  PgColumnName ->
  Maybe PgTableName ->
  PgColumns ->
  Map PgTypeRef PgComposite ->
  [NonEmpty PgColumnName] ->
  PgStructure ->
  PgTable a
mkTable :: forall {k} (a :: k).
PgColumnName
-> Maybe PgTableName
-> PgColumns
-> Map PgTypeRef PgComposite
-> [NonEmpty PgColumnName]
-> PgStructure
-> PgTable a
mkTable (PgColumnName Text
name) Maybe PgTableName
tableName PgColumns
cols Map PgTypeRef PgComposite
types [NonEmpty PgColumnName]
selectors PgStructure
struct =
  forall {k} (a :: k).
PgTableName
-> PgColumns
-> Map PgTypeRef PgComposite
-> TableSelectors
-> TableValues
-> PgStructure
-> PgTable a
PgTable (forall a. a -> Maybe a -> a
fromMaybe (Text -> PgTableName
pgTableName Text
name) Maybe PgTableName
tableName) PgColumns
cols Map PgTypeRef PgComposite
types ([Selector] -> TableSelectors
TableSelectors (NonEmpty PgColumnName -> Selector
mkSelector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NonEmpty PgColumnName]
selectors)) TableValues
values PgStructure
struct
  where
    values :: TableValues
values = [Sql] -> TableValues
TableValues (PgStructure -> [Sql]
mkValues PgStructure
struct)

toTable :: DdTerm -> PgTable a
toTable :: forall {k} (a :: k). DdTerm -> PgTable a
toTable = \case
  DdTerm PgColumnName
name Maybe PgTableName
tableName Bool
unique [Sql]
constr (Prim PgPrimName
t) ->
    forall {k} (a :: k).
PgColumnName
-> Maybe PgTableName
-> PgColumns
-> Map PgTypeRef PgComposite
-> [NonEmpty PgColumnName]
-> PgStructure
-> PgTable a
mkTable PgColumnName
name Maybe PgTableName
tableName PgColumns
cols [] [forall (f :: * -> *) a. Applicative f => a -> f a
pure PgColumnName
name] PgStructure
struct
    where
      cols :: PgColumns
cols = [PgColumn] -> PgColumns
PgColumns [PgColumnName -> ColumnType -> PgColumn
PgColumn PgColumnName
name (PgPrimName -> Bool -> [Sql] -> ColumnType
ColumnPrim PgPrimName
t Bool
unique [Sql]
constr)]
      struct :: PgStructure
struct = [(PgColumnName, StructureType)] -> PgStructure
PgStructure [(PgColumnName
name, PgPrimName -> Bool -> [Sql] -> StructureType
StructurePrim PgPrimName
t Bool
unique [Sql]
constr)]
  DdTerm PgColumnName
name Maybe PgTableName
tableName Bool
_ [Sql]
_ (Comp Text
typeName Comp
c CompInc
i [DdTerm]
sub) ->
    forall {k} (a :: k).
PgColumnName
-> Maybe PgTableName
-> PgColumns
-> Map PgTypeRef PgComposite
-> [NonEmpty PgColumnName]
-> PgStructure
-> PgTable a
mkTable PgColumnName
name Maybe PgTableName
tableName PgColumns
cols Map PgTypeRef PgComposite
types [NonEmpty PgColumnName]
paths PgStructure
struct
    where
      (PgComposite PgCompName
_ PgColumns
cols, PgStructure
struct, Map PgTypeRef PgComposite
types, Bool
_, [NonEmpty PgColumnName]
paths) = Text
-> Comp
-> CompInc
-> [DdTerm]
-> (PgComposite, PgStructure, Map PgTypeRef PgComposite, Bool,
    [NonEmpty PgColumnName])
comp Text
typeName Comp
c CompInc
i [DdTerm]
sub

pgTable ::
  ∀ s .
  ReifyDd s =>
  Dd s ->
  PgTable (DdType s)
pgTable :: forall (s :: DdK). ReifyDd s => Dd s -> PgTable (DdType s)
pgTable Dd s
dd =
  forall {k} (a :: k). DdTerm -> PgTable a
toTable (forall (s :: DdK). ReifyDd s => Dd s -> DdTerm
reifyDd Dd s
dd)

type MkTableSchema :: DdK -> Constraint
class MkTableSchema table where
  tableSchema :: Dd table -> TableSchema (DdType table)

instance (
    ReifyDd table,
    ReifyCodec FullCodec table (DdType table)
  ) => MkTableSchema table where
  tableSchema :: Dd table -> TableSchema (DdType table)
tableSchema Dd table
tab =
    forall a. PgTable a -> Row a -> Params a -> TableSchema a
TableSchema (forall (s :: DdK). ReifyDd s => Dd s -> PgTable (DdType s)
pgTable Dd table
tab) (Decoder (DdType table)
row forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "decodeValue" a => a
#decodeValue) (Encoder (DdType table)
params forall s a. s -> Getting a s a -> a
^. forall a. IsLabel "encodeValue" a => a
#encodeValue)
    where
      Codec Encoder (DdType table)
params Decoder (DdType table)
row = forall (b :: * -> *) (s :: DdK) a. ReifyCodec b s a => Dd s -> b a
reifyCodec @FullCodec Dd table
tab

class CheckedProjection' (check :: Maybe Void) (s :: DdK) where
  checkedProjection' :: Dd s -> ProjectionWitness (DdType s) table

instance CheckedProjection' 'Nothing s where
  checkedProjection' :: forall {k1} (table :: k1).
Dd s -> ProjectionWitness (DdType s) table
checkedProjection' Dd s
_ = forall {k} {k1} (proj :: k) (table :: k1).
ProjectionWitness proj table
ProjectionWitness

class CheckedProjection (proj :: DdK) (table :: DdK) where
  checkedProjection :: Dd proj -> ProjectionWitness (DdType proj) (DdType table)

type CheckProjectionStuck :: ErrorMessage
type CheckProjectionStuck =
  "Could not validate projection fields since there is not enough type information available." %
  "You are most likely missing a constraint for " <> Quoted "CheckedProjection" <> "."

instance (
    MatchProjection proj table match,
    CheckedProjection' match proj
  ) => CheckedProjection proj table where
    checkedProjection :: Dd proj -> ProjectionWitness (DdType proj) (DdType table)
checkedProjection = forall (check :: Maybe Void) (s :: DdK) {k1} (table :: k1).
CheckedProjection' check s =>
Dd s -> ProjectionWitness (DdType s) table
checkedProjection' @match

-- TODO check that the table name matches, otherwise a query using the projection will use the wrong name.
-- also possible to automatically set it, but that might be incompatible with the db view interpreter feature, since
-- the name there can't be propagated here. but it would be possible to check only there and do it automatically here.
projectionWitness ::
  ∀ proj table .
  CheckedProjection proj table =>
  Dd proj ->
  Dd table ->
  ProjectionWitness (DdType proj) (DdType table)
projectionWitness :: forall (proj :: DdK) (table :: DdK).
CheckedProjection proj table =>
Dd proj
-> Dd table -> ProjectionWitness (DdType proj) (DdType table)
projectionWitness Dd proj
proj Dd table
_ =
  forall (proj :: DdK) (table :: DdK).
CheckedProjection proj table =>
Dd proj -> ProjectionWitness (DdType proj) (DdType table)
checkedProjection @proj @table Dd proj
proj

projection ::
  MkTableSchema proj =>
  MkTableSchema table =>
  CheckedProjection proj table =>
  Dd proj ->
  Dd table ->
  Projection (DdType proj) (DdType table)
projection :: forall (proj :: DdK) (table :: DdK).
(MkTableSchema proj, MkTableSchema table,
 CheckedProjection proj table) =>
Dd proj -> Dd table -> Projection (DdType proj) (DdType table)
projection Dd proj
ddProj Dd table
ddTable =
  Projection {Row (DdType proj)
Params (DdType proj)
ProjectionWitness (DdType proj) (DdType table)
PgTable (DdType proj)
TableSchema (DdType table)
$sel:witness:Projection :: ProjectionWitness (DdType proj) (DdType table)
$sel:table:Projection :: TableSchema (DdType table)
$sel:encoder:Projection :: Params (DdType proj)
$sel:decoder:Projection :: Row (DdType proj)
$sel:pg:Projection :: PgTable (DdType proj)
witness :: ProjectionWitness (DdType proj) (DdType table)
encoder :: Params (DdType proj)
decoder :: Row (DdType proj)
pg :: PgTable (DdType proj)
table :: TableSchema (DdType table)
..}
  where
    table :: TableSchema (DdType table)
table = forall (table :: DdK).
MkTableSchema table =>
Dd table -> TableSchema (DdType table)
tableSchema Dd table
ddTable
    TableSchema {Row (DdType proj)
Params (DdType proj)
PgTable (DdType proj)
$sel:encoder:TableSchema :: forall a. TableSchema a -> Params a
$sel:decoder:TableSchema :: forall a. TableSchema a -> Row a
$sel:pg:TableSchema :: forall a. TableSchema a -> PgTable a
encoder :: Params (DdType proj)
decoder :: Row (DdType proj)
pg :: PgTable (DdType proj)
..} = forall (table :: DdK).
MkTableSchema table =>
Dd table -> TableSchema (DdType table)
tableSchema Dd proj
ddProj
    witness :: ProjectionWitness (DdType proj) (DdType table)
witness = forall (proj :: DdK) (table :: DdK).
CheckedProjection proj table =>
Dd proj
-> Dd table -> ProjectionWitness (DdType proj) (DdType table)
projectionWitness Dd proj
ddProj Dd table
ddTable

fullProjection ::
  MkTableSchema table =>
  CheckedProjection table table =>
  Dd table ->
  Projection (DdType table) (DdType table)
fullProjection :: forall (table :: DdK).
(MkTableSchema table, CheckedProjection table table) =>
Dd table -> Projection (DdType table) (DdType table)
fullProjection Dd table
dd =
  forall (proj :: DdK) (table :: DdK).
(MkTableSchema proj, MkTableSchema table,
 CheckedProjection proj table) =>
Dd proj -> Dd table -> Projection (DdType proj) (DdType table)
projection Dd table
dd Dd table
dd

toFullProjection :: TableSchema table -> Projection table table
toFullProjection :: forall table. TableSchema table -> Projection table table
toFullProjection table :: TableSchema table
table@TableSchema {Row table
Params table
PgTable table
encoder :: Params table
decoder :: Row table
pg :: PgTable table
$sel:encoder:TableSchema :: forall a. TableSchema a -> Params a
$sel:decoder:TableSchema :: forall a. TableSchema a -> Row a
$sel:pg:TableSchema :: forall a. TableSchema a -> PgTable a
..} =
  Projection {TableSchema table
table :: TableSchema table
$sel:table:Projection :: TableSchema table
table, $sel:witness:Projection :: ProjectionWitness table table
witness = forall {k} {k1} (proj :: k) (table :: k1).
ProjectionWitness proj table
ProjectionWitness, Row table
Params table
PgTable table
encoder :: Params table
decoder :: Row table
pg :: PgTable table
$sel:encoder:Projection :: Params table
$sel:decoder:Projection :: Row table
$sel:pg:Projection :: PgTable table
..}