{-# language DuplicateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language GADTs #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language RecordWildCards #-}
{-# language StandaloneKindSignatures #-}
{-# language StrictData #-}

module Rel8.Statement.OnConflict
  ( OnConflict(..)
  , Upsert(..)
  , ppOnConflict
  )
where

-- base
import Data.Foldable ( toList )
import Data.Kind ( Type )
import Prelude

-- opaleye
import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye

-- pretty
import Text.PrettyPrint ( Doc, (<+>), ($$), parens, text )

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Schema.Name ( Name, Selects, ppColumn )
import Rel8.Schema.Table ( TableSchema(..) )
import Rel8.Statement.Set ( ppSet )
import Rel8.Statement.Where ( ppWhere )
import Rel8.Table ( Table, toColumns )
import Rel8.Table.Cols ( Cols( Cols ) )
import Rel8.Table.Name ( showNames )
import Rel8.Table.Opaleye ( attributes )
import Rel8.Table.Projection ( Projecting, Projection, apply )


-- | 'OnConflict' represents the @ON CONFLICT@ clause of an @INSERT@
-- statement. This specifies what ought to happen when one or more of the
-- rows proposed for insertion conflict with an existing row in the table.
type OnConflict :: Type -> Type
data OnConflict names
  = Abort
    -- ^ Abort the transaction if there are conflicting rows (Postgres' default)
  | DoNothing
    -- ^ @ON CONFLICT DO NOTHING@
  | DoUpdate (Upsert names)
    -- ^ @ON CONFLICT DO UPDATE@


-- | The @ON CONFLICT (...) DO UPDATE@ clause of an @INSERT@ statement, also
-- known as \"upsert\".
--
-- When an existing row conflicts with a row proposed for insertion,
-- @ON CONFLICT DO UPDATE@ allows you to instead update this existing row. The
-- conflicting row proposed for insertion is then \"excluded\", but its values
-- can still be referenced from the @SET@ and @WHERE@ clauses of the @UPDATE@
-- statement.
--
-- Upsert in Postgres requires an explicit set of \"conflict targets\" — the
-- set of columns comprising the @UNIQUE@ index from conflicts with which we
-- would like to recover.
type Upsert :: Type -> Type
data Upsert names where
  Upsert :: (Selects names exprs, Projecting names index, excluded ~ exprs) =>
    { ()
index :: Projection names index
      -- ^ The set of conflict targets, projected from the set of columns for
      -- the whole table
    , ()
set :: excluded -> exprs -> exprs
      -- ^ How to update each selected row.
    , ()
updateWhere :: excluded -> exprs -> Expr Bool
      -- ^ Which rows to select for update.
    }
    -> Upsert names


ppOnConflict :: TableSchema names -> OnConflict names -> Doc
ppOnConflict :: TableSchema names -> OnConflict names -> Doc
ppOnConflict TableSchema names
schema = \case
  OnConflict names
Abort -> Doc
forall a. Monoid a => a
mempty
  OnConflict names
DoNothing -> String -> Doc
text String
"ON CONFLICT DO NOTHING"
  DoUpdate Upsert names
upsert -> TableSchema names -> Upsert names -> Doc
forall names. TableSchema names -> Upsert names -> Doc
ppUpsert TableSchema names
schema Upsert names
upsert


ppUpsert :: TableSchema names -> Upsert names -> Doc
ppUpsert :: TableSchema names -> Upsert names -> Doc
ppUpsert schema :: TableSchema names
schema@TableSchema {names
columns :: forall names. TableSchema names -> names
columns :: names
columns} Upsert {excluded -> exprs -> exprs
excluded -> exprs -> Expr Bool
Projection names index
updateWhere :: excluded -> exprs -> Expr Bool
set :: excluded -> exprs -> exprs
index :: Projection names index
$sel:updateWhere:Upsert :: ()
$sel:set:Upsert :: ()
$sel:index:Upsert :: ()
..} =
  String -> Doc
text String
"ON CONFLICT" Doc -> Doc -> Doc
<+>
  TableSchema names -> Projection names index -> Doc
forall names index.
(Table Name names, Projecting names index) =>
TableSchema names -> Projection names index -> Doc
ppIndex TableSchema names
schema Projection names index
index Doc -> Doc -> Doc
<+>
  String -> Doc
text String
"DO UPDATE" Doc -> Doc -> Doc
$$
  TableSchema names -> (exprs -> exprs) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> exprs) -> Doc
ppSet TableSchema names
schema (excluded -> exprs -> exprs
set excluded
excluded) Doc -> Doc -> Doc
$$
  TableSchema names -> (exprs -> Expr Bool) -> Doc
forall names exprs.
Selects names exprs =>
TableSchema names -> (exprs -> Expr Bool) -> Doc
ppWhere TableSchema names
schema (excluded -> exprs -> Expr Bool
updateWhere excluded
excluded)
  where
    excluded :: excluded
excluded = TableSchema names -> excluded
forall names exprs.
Selects names exprs =>
TableSchema names -> exprs
attributes TableSchema :: forall names. String -> Maybe String -> names -> TableSchema names
TableSchema
      { schema :: Maybe String
schema = Maybe String
forall a. Maybe a
Nothing
      , name :: String
name = String
"excluded"
      , names
columns :: names
columns :: names
columns
      }


ppIndex :: (Table Name names, Projecting names index)
  => TableSchema names -> Projection names index -> Doc
ppIndex :: TableSchema names -> Projection names index -> Doc
ppIndex TableSchema {names
columns :: names
columns :: forall names. TableSchema names -> names
columns} Projection names index
index =
  Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
Opaleye.commaV String -> Doc
ppColumn ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
forall a b. (a -> b) -> a -> b
$
    Cols Name (Columns index) -> NonEmpty String
forall a. Table Name a => a -> NonEmpty String
showNames (Cols Name (Columns index) -> NonEmpty String)
-> Cols Name (Columns index) -> NonEmpty String
forall a b. (a -> b) -> a -> b
$ Columns index Name -> Cols Name (Columns index)
forall (context :: * -> *) (columns :: HTable).
columns context -> Cols context columns
Cols (Columns index Name -> Cols Name (Columns index))
-> Columns index Name -> Cols Name (Columns index)
forall a b. (a -> b) -> a -> b
$ Projection names index -> Columns names Name -> Columns index Name
forall a b (context :: * -> *).
Projecting a b =>
Projection a b -> Columns a context -> Columns b context
apply Projection names index
index (Columns names Name -> Columns index Name)
-> Columns names Name -> Columns index Name
forall a b. (a -> b) -> a -> b
$ names -> Columns names Name
forall (context :: * -> *) a.
Table context a =>
a -> Columns a context
toColumns names
columns