{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      : Database.Relational.Derives
-- Copyright   : 2013-2017 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines typed SQLs derived from type informations.
module Database.Relational.Derives (
  -- * Query derivation
  specifiedKey,

  uniqueSelect,
  primarySelect,

  -- * Update derivation
  updateByConstraintKey,
  primaryUpdate,

  updateValuesWithKey,

  -- * Derived objects from table
  derivedUniqueRelation,

  -- * Deprecated
  unique,
  primary', primary,
  ) where

import Database.Record (PersistableWidth, ToSql)
import Database.Record.ToSql (unsafeUpdateValuesWithIndexes)

import Database.Relational.SqlSyntax (Record)

import Database.Relational.Table (Table, TableDerivable)
import Database.Relational.Pi (Pi, expandIndexes)
import qualified Database.Relational.Record as Record
import Database.Relational.Projectable (placeholder, (.=.), (!))
import Database.Relational.Monad.Class (wheres)
import Database.Relational.Monad.BaseType (Relation, relationWidth)
import Database.Relational.Relation
  (derivedRelation, relation, relation', query, UniqueRelation, unsafeUnique)
import Database.Relational.Constraint
   (Key, Primary, Unique, projectionKey, uniqueKey,
    HasConstraintKey(constraintKey))
import qualified Database.Relational.Constraint as Constraint
import Database.Relational.Type (KeyUpdate, typedKeyUpdate)


-- | Query restricted with specified key.
specifiedKey :: PersistableWidth p
             => Pi a p        -- ^ Projection path
             -> Relation () a -- ^ 'Relation' to add restriction.
             -> Relation p a  -- ^ Result restricted 'Relation'
specifiedKey :: Pi a p -> Relation () a -> Relation p a
specifiedKey Pi a p
key Relation () a
rel = SimpleQuery p a -> Relation p a
forall p r. SimpleQuery p r -> Relation p r
relation' (SimpleQuery p a -> Relation p a)
-> SimpleQuery p a -> Relation p a
forall a b. (a -> b) -> a -> b
$ do
  Record Flat a
q <- Relation () a -> Orderings Flat QueryCore (Record Flat a)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () a
rel
  (PlaceHolders p
param, ()) <- (Record Flat p -> Orderings Flat QueryCore ())
-> Orderings Flat QueryCore (PlaceHolders p, ())
forall t c (m :: * -> *) a.
(PersistableWidth t, SqlContext c, Monad m) =>
(Record c t -> m a) -> m (PlaceHolders t, a)
placeholder (\Record Flat p
ph -> Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ PersistableRecordWidth a
-> Record Flat a -> Pi a p -> Record Flat p
forall a c b.
PersistableRecordWidth a -> Record c a -> Pi a b -> Record c b
Record.wpi (Relation () a -> PersistableRecordWidth a
forall p r. Relation p r -> PersistableRecordWidth r
relationWidth Relation () a
rel) Record Flat a
q Pi a p
key Record Flat p -> Record Flat p -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record Flat p
ph)
  (PlaceHolders p, Record Flat a) -> SimpleQuery p a
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders p
param, Record Flat a
q)

-- | Query restricted with specified unique key.
uniqueSelect :: PersistableWidth p
             => Key Unique a p -- ^ Unique key proof object which record type is 'a' and key type is 'p'.
             -> Relation () a  -- ^ 'Relation' to add restriction.
             -> Relation p a   -- ^ Result restricted 'Relation'
uniqueSelect :: Key Unique a p -> Relation () a -> Relation p a
uniqueSelect =  Pi a p -> Relation () a -> Relation p a
forall p a.
PersistableWidth p =>
Pi a p -> Relation () a -> Relation p a
specifiedKey (Pi a p -> Relation () a -> Relation p a)
-> (Key Unique a p -> Pi a p)
-> Key Unique a p
-> Relation () a
-> Relation p a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key Unique a p -> Pi a p
forall c r ct. Key c r ct -> Pi r ct
projectionKey

{-# DEPRECATED unique "use `uniqueSelect` instead of this." #-}
-- | Deprecated.
unique :: PersistableWidth p
       => Key Unique a p
       -> Relation () a
       -> Relation p a
unique :: Key Unique a p -> Relation () a -> Relation p a
unique = Key Unique a p -> Relation () a -> Relation p a
forall p a.
PersistableWidth p =>
Key Unique a p -> Relation () a -> Relation p a
uniqueSelect

{-# DEPRECATED primary' "use `primarySelect` instead of this." #-}
-- | Deprecated.
primary' :: PersistableWidth p
         => Key Primary a p -- ^ Primary key proof object which record type is 'a' and key type is 'p'.
         -> Relation () a   -- ^ 'Relation' to add restriction.
         -> Relation p a    -- ^ Result restricted 'Relation'
primary' :: Key Primary a p -> Relation () a -> Relation p a
primary' =  Pi a p -> Relation () a -> Relation p a
forall p a.
PersistableWidth p =>
Pi a p -> Relation () a -> Relation p a
specifiedKey (Pi a p -> Relation () a -> Relation p a)
-> (Key Primary a p -> Pi a p)
-> Key Primary a p
-> Relation () a
-> Relation p a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key Primary a p -> Pi a p
forall c r ct. Key c r ct -> Pi r ct
projectionKey

-- | Query restricted with inferred primary key.
primarySelect :: HasConstraintKey Primary a p
              => Relation () a -- ^ 'Relation' to add restriction.
              -> Relation p a  -- ^ Result restricted 'Relation'
primarySelect :: Relation () a -> Relation p a
primarySelect =  Key Primary a p -> Relation () a -> Relation p a
forall p a.
PersistableWidth p =>
Key Primary a p -> Relation () a -> Relation p a
primary' Key Primary a p
forall c r ct. HasConstraintKey c r ct => Key c r ct
constraintKey

{-# DEPRECATED primary "use `primarySelect` instead of this." #-}
-- | Deprecated.
primary :: HasConstraintKey Primary a p
        => Relation () a
        -> Relation p a
primary :: Relation () a -> Relation p a
primary = Relation () a -> Relation p a
forall a p.
HasConstraintKey Primary a p =>
Relation () a -> Relation p a
primarySelect

-- | Convert from Haskell type `r` into SQL value `q` list expected by update form like
--
-- /UPDATE <table> SET c0 = ?, c1 = ?, ..., cn = ? WHERE key0 = ? AND key1 = ? AND key2 = ? ... /
--
--   using derived 'RecordToSql' proof object.
updateValuesWithKey :: ToSql q r
                    => Pi r p
                    -> r
                    -> [q]
updateValuesWithKey :: Pi r p -> r -> [q]
updateValuesWithKey =  [Int] -> r -> [q]
forall q ra. ToSql q ra => [Int] -> ra -> [q]
unsafeUpdateValuesWithIndexes ([Int] -> r -> [q]) -> (Pi r p -> [Int]) -> Pi r p -> r -> [q]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pi r p -> [Int]
forall a b. PersistableWidth a => Pi a b -> [Int]
expandIndexes

-- | Typed 'KeyUpdate' using specified constraint key.
updateByConstraintKey :: Table r       -- ^ 'Table' to update
                      -> Key c r p     -- ^ Key with constraint 'c', record type 'r' and columns type 'p'
                      -> KeyUpdate p r -- ^ Result typed 'Update'
updateByConstraintKey :: Table r -> Key c r p -> KeyUpdate p r
updateByConstraintKey Table r
table' = Table r -> Pi r p -> KeyUpdate p r
forall a p. Table a -> Pi a p -> KeyUpdate p a
typedKeyUpdate Table r
table' (Pi r p -> KeyUpdate p r)
-> (Key c r p -> Pi r p) -> Key c r p -> KeyUpdate p r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key c r p -> Pi r p
forall c r ct. Key c r ct -> Pi r ct
Constraint.projectionKey

-- | Typed 'KeyUpdate' using inferred primary key.
primaryUpdate :: (HasConstraintKey Primary r p)
              => Table r       -- ^ 'Table' to update
              -> KeyUpdate p r -- ^ Result typed 'Update'
primaryUpdate :: Table r -> KeyUpdate p r
primaryUpdate Table r
table' = Table r -> Key Unique r p -> KeyUpdate p r
forall r c p. Table r -> Key c r p -> KeyUpdate p r
updateByConstraintKey Table r
table' (Key Primary r p -> Key Unique r p
forall ct r.
PersistableWidth ct =>
Key Primary r ct -> Key Unique r ct
uniqueKey Key Primary r p
forall c r ct. HasConstraintKey c r ct => Key c r ct
constraintKey)

-- | 'UniqueRelation' inferred from table.
derivedUniqueRelation :: TableDerivable r
                      => Key Unique r k        -- ^ Unique key proof object which record type is 'a' and key type is 'p'.
                      -> Record c k            -- ^ Unique key value to specify.
                      -> UniqueRelation () c r -- ^ Result restricted 'Relation'
derivedUniqueRelation :: Key Unique r k -> Record c k -> UniqueRelation () c r
derivedUniqueRelation Key Unique r k
uk Record c k
kp = Relation () r -> UniqueRelation () c r
forall p r c. Relation p r -> UniqueRelation p c r
unsafeUnique (Relation () r -> UniqueRelation () c r)
-> (QuerySimple (Record Flat r) -> Relation () r)
-> QuerySimple (Record Flat r)
-> UniqueRelation () c r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuerySimple (Record Flat r) -> Relation () r
forall r. QuerySimple (Record Flat r) -> Relation () r
relation (QuerySimple (Record Flat r) -> UniqueRelation () c r)
-> QuerySimple (Record Flat r) -> UniqueRelation () c r
forall a b. (a -> b) -> a -> b
$ do
  Record Flat r
r <- Relation () r -> QuerySimple (Record Flat r)
forall (m :: * -> *) r.
(MonadQualify ConfigureQuery m, MonadQuery m) =>
Relation () r -> m (Record Flat r)
query Relation () r
forall r. TableDerivable r => Relation () r
derivedRelation
  Predicate Flat -> Orderings Flat QueryCore ()
forall (m :: * -> *).
MonadRestrict Flat m =>
Predicate Flat -> m ()
wheres (Predicate Flat -> Orderings Flat QueryCore ())
-> Predicate Flat -> Orderings Flat QueryCore ()
forall a b. (a -> b) -> a -> b
$ Record Flat r
r Record Flat r -> Pi r k -> Record Flat k
forall a c b.
PersistableWidth a =>
Record c a -> Pi a b -> Record c b
! Key Unique r k -> Pi r k
forall c r ct. Key c r ct -> Pi r ct
projectionKey Key Unique r k
uk Record Flat k -> Record Flat k -> Predicate Flat
forall c ft.
OperatorContext c =>
Record c ft -> Record c ft -> Record c (Maybe Bool)
.=. Record c k -> Record Flat k
forall c r c'. Record c r -> Record c' r
Record.unsafeChangeContext Record c k
kp
  Record Flat r -> QuerySimple (Record Flat r)
forall (m :: * -> *) a. Monad m => a -> m a
return Record Flat r
r