{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Database.Beam.Query
    ( -- * Query type
      module Database.Beam.Query.Types

    -- ** Query expression contexts
    -- | A context is a type-level value that signifies where an expression can
    --   be used. For example, 'QExpr' corresponds to 'QGenExpr's that result in
    --   values. In reality, 'QExpr' is really 'QGenExpr' parameterized over the
    --   'QValueContext'. Similarly, 'QAgg' represents expressions that contain
    --   aggregates, but it is just 'QGenExpr' parameterized over
    --   'QAggregateContext'
    , QAggregateContext, QGroupingContext, QValueContext
    , QWindowingContext, QWindowFrameContext

    , QGenExprTable, QExprTable

    , QAssignment, QField, QFieldAssignment

    , QBaseScope

    , module Database.Beam.Query.Combinators
    , module Database.Beam.Query.Extensions

    , module Database.Beam.Query.Relationships

    , module Database.Beam.Query.CTE

    , module Database.Beam.Query.Extract

    -- * Operators
    , module Database.Beam.Query.Operator

    -- ** ANSI SQL Booleans
    , Beam.SqlBool
    , isTrue_, isNotTrue_
    , isFalse_, isNotFalse_
    , isUnknown_, isNotUnknown_
    , unknownAs_, sqlBool_
    , possiblyNullBool_
    , fromPossiblyNullBool_

    -- ** Unquantified comparison operators
    , HasSqlEqualityCheck(..), HasSqlQuantifiedEqualityCheck(..)
    , SqlEq(..), SqlOrd(..)

    -- ** Quantified Comparison Operators #quantified-comparison-operator#
    , SqlEqQuantified(..), SqlOrdQuantified(..)
    , QQuantified
    , anyOf_, allOf_, anyIn_, allIn_
    , between_
    , in_

    , module Database.Beam.Query.Aggregate

    , module Database.Beam.Query.CustomSQL

    , module Database.Beam.Query.DataTypes

    -- * SQL Command construction and execution
    -- ** @SELECT@
    , SqlSelect(..)
    , select, selectWith, lookup_
    , runSelectReturningList
    , runSelectReturningOne
    , dumpSqlSelect

    -- ** @INSERT@
    , SqlInsert(..)
    , insert, insertOnly
    , runInsert

    , SqlInsertValues(..)
    , insertExpressions
    , insertValues
    , insertFrom
    , insertData

    -- ** @UPDATE@
    , SqlUpdate(..)
    , update, save
    , updateTable, set, setFieldsTo
    , toNewValue, toOldValue, toUpdatedValue
    , toUpdatedValueMaybe
    , updateRow, updateTableRow
    , runUpdate

    -- ** @DELETE@
    , SqlDelete(..)
    , delete
    , runDelete ) where

import Prelude hiding (lookup)

import Database.Beam.Query.Aggregate
import Database.Beam.Query.Combinators
import Database.Beam.Query.CTE ( With, ReusableQ, selecting, reuse )
import qualified Database.Beam.Query.CTE as CTE
import Database.Beam.Query.CustomSQL
import Database.Beam.Query.DataTypes
import Database.Beam.Query.Extensions
import Database.Beam.Query.Extract
import Database.Beam.Query.Internal
import Database.Beam.Query.Operator hiding (SqlBool)
import qualified Database.Beam.Query.Operator as Beam
import Database.Beam.Query.Ord
import Database.Beam.Query.Relationships
import Database.Beam.Query.Types (QGenExpr) -- hide QGenExpr constructor
import Database.Beam.Query.Types hiding (QGenExpr)

import Database.Beam.Backend.SQL
import Database.Beam.Backend.SQL.Builder
import Database.Beam.Schema.Tables

import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.State.Strict

import Data.Functor.Const (Const(..))
import Data.Text (Text)
import Data.Proxy

import Lens.Micro ((^.))

-- * Query

data QBaseScope

-- | A version of the table where each field is a 'QGenExpr'
type QGenExprTable ctxt be s tbl = tbl (QGenExpr ctxt be s)

type QExprTable be s tbl = QGenExprTable QValueContext be s tbl

-- * SELECT

-- | Represents a select statement in the given backend, returning
-- rows of type 'a'.
newtype SqlSelect be a
    = SqlSelect (BeamSqlBackendSelectSyntax be)

-- | Build a 'SqlSelect' for the given 'Q'.
select :: forall be db res
        . ( BeamSqlBackend be, HasQBuilder be, Projectible be res )
       => Q be db QBaseScope res -> SqlSelect be (QExprToIdentity res)
select q =
  SqlSelect (buildSqlQuery "t" q)

-- | Create a 'SqlSelect' for a query which may have common table
-- expressions. See the documentation of 'With' for more details.
selectWith :: forall be db res
            . ( BeamSqlBackend be, BeamSql99CommonTableExpressionBackend be
              , HasQBuilder be, Projectible be res )
           => With be db (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res)
selectWith (CTE.With mkQ) =
    let (q, (recursiveness, ctes)) = evalState (runWriterT mkQ) 0
    in case recursiveness of
         CTE.Nonrecursive -> SqlSelect (withSyntax ctes
                                                   (buildSqlQuery "t" q))
         CTE.Recursive    -> SqlSelect (withRecursiveSyntax ctes
                                                            (buildSqlQuery "t" q))

-- | Convenience function to generate a 'SqlSelect' that looks up a table row
--   given a primary key.
lookup_ :: ( Database be db, Table table

           , BeamSqlBackend be, HasQBuilder be
           , SqlValableTable be (PrimaryKey table)
           , HasTableEquality be (PrimaryKey table)
           )
        => DatabaseEntity be db (TableEntity table)
        -> PrimaryKey table Identity
        -> SqlSelect be (table Identity)
lookup_ tbl tblKey =
  select $
  filter_ (\t -> pk t ==. val_ tblKey) $
  all_ tbl

-- | Run a 'SqlSelect' in a 'MonadBeam' and get the results as a list
runSelectReturningList ::
  (MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>
  SqlSelect be a -> m [ a ]
runSelectReturningList (SqlSelect s) =
  runReturningList (selectCmd s)

-- | Run a 'SqlSelect' in a 'MonadBeam' and get the unique result, if there is
--   one. Both no results as well as more than one result cause this to return
--   'Nothing'.
runSelectReturningOne ::
  (MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>
  SqlSelect be a -> m (Maybe a)
runSelectReturningOne (SqlSelect s) =
  runReturningOne (selectCmd s)

-- | Use a special debug syntax to print out an ANSI Standard @SELECT@ statement
--   that may be generated for a given 'Q'.
dumpSqlSelect :: Projectible (MockSqlBackend SqlSyntaxBuilder) res
              => Q (MockSqlBackend SqlSyntaxBuilder) db QBaseScope res -> IO ()
dumpSqlSelect q =
    let SqlSelect s = select q
    in putStrLn (renderSql s)

-- * INSERT

-- | Represents a SQL @INSERT@ command that has not yet been run
data SqlInsert be (table :: (* -> *) -> *)
  = SqlInsert !(TableSettings table) !(BeamSqlBackendInsertSyntax be)
  | SqlInsertNoRows

-- | Generate a 'SqlInsert' over only certain fields of a table
insertOnly :: ( BeamSqlBackend be, ProjectibleWithPredicate AnyType () Text (QExprToField r) )
           => DatabaseEntity be db (TableEntity table)
              -- ^ Table to insert into
           -> (table (QField s) -> QExprToField r)
           -> SqlInsertValues be r
              -- ^ Values to insert. See 'insertValues', 'insertExpressions', 'insertData', and 'insertFrom' for possibilities.
           -> SqlInsert be table
insertOnly _ _ SqlInsertValuesEmpty = SqlInsertNoRows
insertOnly (DatabaseEntity dt@(DatabaseTable {})) mkProj (SqlInsertValues vs) =
    SqlInsert (dbTableSettings dt) (insertStmt (tableNameFromEntity dt) proj vs)
  where
    tblFields = changeBeamRep (\(Columnar' fd) -> Columnar' (QField False (dbTableCurrentName dt) (fd ^. fieldName)))
                              (dbTableSettings dt)
    proj = execWriter (project' (Proxy @AnyType) (Proxy @((), Text))
                                (\_ _ f -> tell [f] >> pure f)
                                (mkProj tblFields))

-- | Generate a 'SqlInsert' given a table and a source of values.
insert :: ( BeamSqlBackend be, ProjectibleWithPredicate AnyType () Text (table (QField s)) )
       => DatabaseEntity be db (TableEntity table)
          -- ^ Table to insert into
       -> SqlInsertValues be (table (QExpr be s))
          -- ^ Values to insert. See 'insertValues', 'insertExpressions', and 'insertFrom' for possibilities.
       -> SqlInsert be table
insert tbl values = insertOnly tbl id values

-- | Run a 'SqlInsert' in a 'MonadBeam'
runInsert :: (BeamSqlBackend be, MonadBeam be m)
          => SqlInsert be table -> m ()
runInsert SqlInsertNoRows = pure ()
runInsert (SqlInsert _ i) = runNoReturn (insertCmd i)

-- | Represents a source of values that can be inserted into a table shaped like
--   'tbl'.
data SqlInsertValues be proj --(tbl :: (* -> *) -> *)
    = SqlInsertValues (BeamSqlBackendInsertValuesSyntax be)
    | SqlInsertValuesEmpty

-- | Build a 'SqlInsertValues' from series of expressions in tables
insertExpressions :: forall be table s
                   . ( BeamSqlBackend be, Beamable table )
                  => (forall s'. [ table (QExpr be s') ])
                  -> SqlInsertValues be (table (QExpr be s))
insertExpressions tbls =
  case sqlExprs of
    [] -> SqlInsertValuesEmpty
    _  -> SqlInsertValues (insertSqlExpressions sqlExprs)
    where
      sqlExprs = map mkSqlExprs tbls

      mkSqlExprs :: forall s'. table (QExpr be s') -> [ BeamSqlBackendExpressionSyntax be ]
      mkSqlExprs = allBeamValues (\(Columnar' (QExpr x)) -> x "t")

-- | Build a 'SqlInsertValues' from concrete table values
insertValues :: forall be table s
              . ( BeamSqlBackend be, Beamable table
                , FieldsFulfillConstraint (BeamSqlBackendCanSerialize be) table )
             => [ table Identity ]
             -> SqlInsertValues be (table (QExpr be s))
insertValues x = insertExpressions (map val_ x :: forall s'. [table (QExpr be s') ])

-- | Build a 'SqlInsertValues' from arbitrarily shaped data containing expressions
insertData :: forall be r
            . ( Projectible be r, BeamSqlBackend be )
           => [ r ] -> SqlInsertValues be r
insertData rows =
  case rows of
    [] -> SqlInsertValuesEmpty
    _  -> SqlInsertValues (insertSqlExpressions (map (\row -> project (Proxy @be) row "t") rows))

-- | Build a 'SqlInsertValues' from a 'SqlSelect' that returns the same table
insertFrom :: ( BeamSqlBackend be, HasQBuilder be
              , Projectible be r )
           => Q be db QBaseScope r
           -> SqlInsertValues be r
insertFrom s = SqlInsertValues (insertFromSql (buildSqlQuery "t" s))

-- * UPDATE

-- | Represents a SQL @UPDATE@ statement for the given @table@.
data SqlUpdate be (table :: (* -> *) -> *)
  = SqlUpdate !(TableSettings table) !(BeamSqlBackendUpdateSyntax be)
  | SqlIdentityUpdate -- An update with no assignments

-- | Build a 'SqlUpdate' given a table, a list of assignments, and a way to
--   build a @WHERE@ clause.
--
--   See the '(<-.)' operator for ways to build assignments. The argument to the
--   second argument is a the table parameterized over 'QField', which
--   represents the left hand side of assignments. Sometimes, you'd like to also
--   get the current value of a particular column. You can use the 'current_'
--   function to convert a 'QField' to a 'QExpr'.
update :: ( BeamSqlBackend be, Beamable table )
       => DatabaseEntity be db (TableEntity table)
          -- ^ The table to insert into
       -> (forall s. table (QField s) -> QAssignment be s)
          -- ^ A sequence of assignments to make.
       -> (forall s. table (QExpr be s) -> QExpr be s Bool)
          -- ^ Build a @WHERE@ clause given a table containing expressions
       -> SqlUpdate be table
update (DatabaseEntity dt@(DatabaseTable {})) mkAssignments mkWhere =
  case assignments of
    [] -> SqlIdentityUpdate
    _  -> SqlUpdate (dbTableSettings dt)
                    (updateStmt (tableNameFromEntity dt)
                       assignments (Just (where_ "t")))
  where
    QAssignment assignments = mkAssignments tblFields
    QExpr where_ = mkWhere tblFieldExprs

    tblFields = changeBeamRep (\(Columnar' fd) -> Columnar' (QField False (dbTableCurrentName dt) (fd ^. fieldName)))
                              (dbTableSettings dt)
    tblFieldExprs = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (pure (fieldE (unqualifiedField nm))))) tblFields

-- | A specialization of 'update' that matches the given (already existing) row
updateRow :: ( BeamSqlBackend be, Table table
             , HasTableEquality be (PrimaryKey table)
             , SqlValableTable be (PrimaryKey table) )
          => DatabaseEntity be db (TableEntity table)
             -- ^ The table to insert into
          -> table Identity
             -- ^ The row to update
          -> (forall s. table (QField s) -> QAssignment be s)
             -- ^ A sequence of assignments to make.
          -> SqlUpdate be table
updateRow tbl row update' =
  update tbl update' (references_ (val_ (pk row)))

-- | A specialization of 'update' that is more convenient for normal tables.
updateTable :: forall table db be
             . ( BeamSqlBackend be, Beamable table )
            => DatabaseEntity be db (TableEntity table)
               -- ^ The table to update
            -> table (QFieldAssignment be table)
               -- ^ Updates to be made (use 'set' to construct an empty field)
            -> (forall s. table (QExpr be s) -> QExpr be s Bool)
            -> SqlUpdate be table
updateTable tblEntity assignments mkWhere =
  let mkAssignments :: forall s. table (QField s) -> QAssignment be s
      mkAssignments tblFields =
        let tblExprs = changeBeamRep (\(Columnar' fd) -> Columnar' (current_ fd)) tblFields
        in execWriter $
           zipBeamFieldsM
             (\(Columnar' field :: Columnar' (QField s) a)
               c@(Columnar' (QFieldAssignment mkAssignment)) ->
                case mkAssignment tblExprs of
                  Nothing -> pure c
                  Just newValue -> do
                    tell (field <-. newValue)
                    pure c)
             tblFields assignments

  in update tblEntity mkAssignments mkWhere

-- | Convenience form of 'updateTable' that generates a @WHERE@ clause
-- that matches only the already existing entity
updateTableRow :: ( BeamSqlBackend be, Table table
                  , HasTableEquality be (PrimaryKey table)
                  , SqlValableTable be (PrimaryKey table) )
               => DatabaseEntity be db (TableEntity table)
                  -- ^ The table to update
               -> table Identity
                  -- ^ The row to update
               -> table (QFieldAssignment be table)
                  -- ^ Updates to be made (use 'set' to construct an empty field)
               -> SqlUpdate be table
updateTableRow tbl row update' =
  updateTable tbl update' (references_ (val_ (pk row)))

set :: forall table be table'. Beamable table => table (QFieldAssignment be table')
set = changeBeamRep (\_ -> Columnar' (QFieldAssignment (\_ -> Nothing))) (tblSkeleton :: TableSkeleton table)

setFieldsTo :: forall table be table'
             . Table table => (forall s. table (QExpr be s)) -> table (QFieldAssignment be table')
setFieldsTo tbl =

  runIdentity $
  zipBeamFieldsM (\(Columnar' (Const columnIx))
                   (Columnar' (QExpr newValue)) ->
                    if columnIx `elem` primaryKeyIndices
                    then pure $ Columnar' toOldValue
                    else pure $ Columnar' (toNewValue (QExpr newValue)))
                 indexedTable tbl

  where
    indexedTable :: table (Const Int)
    indexedTable =
      flip evalState 0 $
      zipBeamFieldsM (\_ _ -> do
                         n <- get
                         put (n + 1)
                         return (Columnar' (Const n)))
        (tblSkeleton :: TableSkeleton table) (tblSkeleton :: TableSkeleton table)

    primaryKeyIndices :: [ Int ]
    primaryKeyIndices = allBeamValues (\(Columnar' (Const ix)) -> ix) (primaryKey indexedTable)

-- | Use with 'set' to set a field to an explicit new value that does
-- not depend on any other value
toNewValue :: (forall s. QExpr be s a) -> QFieldAssignment be table a
toNewValue newVal = toUpdatedValue (\_ -> newVal)

-- | Use with 'set' to not modify the field
toOldValue :: QFieldAssignment be table a
toOldValue = toUpdatedValueMaybe (\_ -> Nothing)

-- | Use with 'set' to set a field to a new value that is calculated
-- based on one or more fields from the existing row
toUpdatedValue :: (forall s. table (QExpr be s) -> QExpr be s a) -> QFieldAssignment be table a
toUpdatedValue mkNewVal = toUpdatedValueMaybe (Just <$> mkNewVal)

-- | Use with 'set' to optionally set a fiield to a new value,
-- calculated based on one or more fields from the existing row
toUpdatedValueMaybe :: (forall s. table (QExpr be s) -> Maybe (QExpr be s a)) -> QFieldAssignment be table a
toUpdatedValueMaybe = QFieldAssignment

-- | Generate a 'SqlUpdate' that will update the given table row with the given value.
--
--   The SQL @UPDATE@ that is generated will set every non-primary key field for
--   the row where each primary key field is exactly what is given.
--
--   Note: This is a pure SQL @UPDATE@ command. This does not upsert or merge values.
save :: forall table be db.
        ( Table table
        , BeamSqlBackend be

        , SqlValableTable be (PrimaryKey table)
        , SqlValableTable be table

        , HasTableEquality be (PrimaryKey table)
        )
     => DatabaseEntity be db (TableEntity table)
        -- ^ Table to update
     -> table Identity
        -- ^ Value to set to
     -> SqlUpdate be table
save tbl v =
  updateTableRow tbl v
    (setFieldsTo (val_ v))

-- | Run a 'SqlUpdate' in a 'MonadBeam'.
runUpdate :: (BeamSqlBackend be, MonadBeam be m)
          => SqlUpdate be tbl -> m ()
runUpdate (SqlUpdate _ u) = runNoReturn (updateCmd u)
runUpdate SqlIdentityUpdate = pure ()

-- * DELETE

-- | Represents a SQL @DELETE@ statement for the given @table@
data SqlDelete be (table :: (* -> *) -> *)
  = SqlDelete !(TableSettings table) !(BeamSqlBackendDeleteSyntax be)

-- | Build a 'SqlDelete' from a table and a way to build a @WHERE@ clause
delete :: forall be db table
        . BeamSqlBackend be
       => DatabaseEntity be db (TableEntity table)
          -- ^ Table to delete from
       -> (forall s. (forall s'. table (QExpr be s')) -> QExpr be s Bool)
          -- ^ Build a @WHERE@ clause given a table containing expressions
       -> SqlDelete be table
delete (DatabaseEntity dt@(DatabaseTable {})) mkWhere =
  SqlDelete (dbTableSettings dt)
            (deleteStmt (tableNameFromEntity dt) alias (Just (where_ "t")))
  where
    supportsAlias = deleteSupportsAlias (Proxy @(BeamSqlBackendDeleteSyntax be))

    tgtName = "delete_target"
    alias = if supportsAlias then Just tgtName else Nothing
    mkField = if supportsAlias then qualifiedField tgtName else unqualifiedField

    QExpr where_ = mkWhere (changeBeamRep (\(Columnar' fd) -> Columnar' (QExpr (pure (fieldE (mkField (fd ^. fieldName))))))
                             (dbTableSettings dt))

-- | Run a 'SqlDelete' in a 'MonadBeam'
runDelete :: (BeamSqlBackend be, MonadBeam be m)
          => SqlDelete be table -> m ()
runDelete (SqlDelete _ d) = runNoReturn (deleteCmd d)