{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

-- |
-- Module      : Database.Relational.Monad.Trans.Join
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines monad transformer which lift to basic 'MonadQuery'.
module Database.Relational.Monad.Trans.Join
       ( -- * Transformer into join query
         QueryJoin, join',

         -- * Result
         extractProduct,

         -- * Unsafe API
         unsafeSubQueryWithAttr,
       ) where

import Prelude hiding (product)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Control.Monad.Trans.State (modify, StateT, runStateT)
import Control.Applicative (Applicative, (<$>))
import Control.Arrow (second, (***))
import Data.Maybe (fromMaybe)
import Data.Monoid (Last (Last, getLast))

import Database.Relational.Internal.ContextType (Flat)
import Database.Relational.Internal.Config (addQueryTableAliasAS)
import Database.Relational.SqlSyntax
  (Duplication (All), NodeAttr (Just', Maybe), Predicate, Record,
   SubQuery, Qualified, JoinProduct, restrictProduct, growProduct, )

import Database.Relational.Monad.Class (liftQualify)
import Database.Relational.Monad.Trans.JoinState
  (JoinContext, primeJoinContext, updateProduct, joinProduct)
import qualified Database.Relational.Record as Record
import Database.Relational.Projectable (PlaceHolders, unsafeAddPlaceHolders)
import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig, qualifyQuery, Relation, untypeRelation)
import Database.Relational.Monad.Class (MonadQualify (..), MonadQuery (..))


-- | 'StateT' type to accumulate join product context.
newtype QueryJoin m a =
  QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a)
  deriving (Applicative (QueryJoin m)
a -> QueryJoin m a
Applicative (QueryJoin m)
-> (forall a b.
    QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b)
-> (forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b)
-> (forall a. a -> QueryJoin m a)
-> Monad (QueryJoin m)
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall a. a -> QueryJoin m a
forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall a b. QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
forall (m :: * -> *). Monad m => Applicative (QueryJoin m)
forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> QueryJoin m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
>> :: QueryJoin m a -> QueryJoin m b -> QueryJoin m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
>>= :: QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> (a -> QueryJoin m b) -> QueryJoin m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (QueryJoin m)
Monad, a -> QueryJoin m b -> QueryJoin m a
(a -> b) -> QueryJoin m a -> QueryJoin m b
(forall a b. (a -> b) -> QueryJoin m a -> QueryJoin m b)
-> (forall a b. a -> QueryJoin m b -> QueryJoin m a)
-> Functor (QueryJoin m)
forall a b. a -> QueryJoin m b -> QueryJoin m a
forall a b. (a -> b) -> QueryJoin m a -> QueryJoin m b
forall (m :: * -> *) a b.
Functor m =>
a -> QueryJoin m b -> QueryJoin m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QueryJoin m a -> QueryJoin m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> QueryJoin m b -> QueryJoin m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> QueryJoin m b -> QueryJoin m a
fmap :: (a -> b) -> QueryJoin m a -> QueryJoin m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QueryJoin m a -> QueryJoin m b
Functor, Functor (QueryJoin m)
a -> QueryJoin m a
Functor (QueryJoin m)
-> (forall a. a -> QueryJoin m a)
-> (forall a b.
    QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b)
-> (forall a b c.
    (a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c)
-> (forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b)
-> (forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m a)
-> Applicative (QueryJoin m)
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
QueryJoin m a -> QueryJoin m b -> QueryJoin m a
QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
forall a. a -> QueryJoin m a
forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m a
forall a b. QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall a b. QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
forall a b c.
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
forall (m :: * -> *). Monad m => Functor (QueryJoin m)
forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m a
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
forall (m :: * -> *) a b.
Monad m =>
QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: QueryJoin m a -> QueryJoin m b -> QueryJoin m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m a
*> :: QueryJoin m a -> QueryJoin m b -> QueryJoin m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m a -> QueryJoin m b -> QueryJoin m b
liftA2 :: (a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> QueryJoin m a -> QueryJoin m b -> QueryJoin m c
<*> :: QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
QueryJoin m (a -> b) -> QueryJoin m a -> QueryJoin m b
pure :: a -> QueryJoin m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (QueryJoin m)
Applicative)

instance MonadTrans QueryJoin where
  lift :: m a -> QueryJoin m a
lift = StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) a
 -> QueryJoin m a)
-> (m a -> StateT JoinContext (WriterT (Last Duplication) m) a)
-> m a
-> QueryJoin m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last Duplication) m a
-> StateT JoinContext (WriterT (Last Duplication) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Last Duplication) m a
 -> StateT JoinContext (WriterT (Last Duplication) m) a)
-> (m a -> WriterT (Last Duplication) m a)
-> m a
-> StateT JoinContext (WriterT (Last Duplication) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> WriterT (Last Duplication) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Lift to 'QueryJoin'
join' :: Monad m => m a -> QueryJoin m a
join' :: m a -> QueryJoin m a
join' = m a -> QueryJoin m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Unsafely update join product context.
updateContext :: Monad m => (JoinContext -> JoinContext) -> QueryJoin m ()
updateContext :: (JoinContext -> JoinContext) -> QueryJoin m ()
updateContext =  StateT JoinContext (WriterT (Last Duplication) m) ()
-> QueryJoin m ()
forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin (StateT JoinContext (WriterT (Last Duplication) m) ()
 -> QueryJoin m ())
-> ((JoinContext -> JoinContext)
    -> StateT JoinContext (WriterT (Last Duplication) m) ())
-> (JoinContext -> JoinContext)
-> QueryJoin m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JoinContext -> JoinContext)
-> StateT JoinContext (WriterT (Last Duplication) m) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify

-- | Add last join product restriction.
updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction :: Predicate Flat -> QueryJoin m ()
updateJoinRestriction Predicate Flat
e = (JoinContext -> JoinContext) -> QueryJoin m ()
forall (m :: * -> *).
Monad m =>
(JoinContext -> JoinContext) -> QueryJoin m ()
updateContext ((Maybe (Node (DList (Predicate Flat)))
 -> Node (DList (Predicate Flat)))
-> JoinContext -> JoinContext
updateProduct Maybe (Node (DList (Predicate Flat)))
-> Node (DList (Predicate Flat))
d)  where
  d :: Maybe (Node (DList (Predicate Flat)))
-> Node (DList (Predicate Flat))
d  Maybe (Node (DList (Predicate Flat)))
Nothing  = [Char] -> Node (DList (Predicate Flat))
forall a. HasCallStack => [Char] -> a
error [Char]
"on: Product is empty! Restrict target product is not found!"
  d (Just Node (DList (Predicate Flat))
pt) = Node (DList (Predicate Flat))
-> Predicate Flat -> Node (DList (Predicate Flat))
restrictProduct Node (DList (Predicate Flat))
pt Predicate Flat
e

instance MonadQualify q m => MonadQualify q (QueryJoin m) where
  liftQualify :: q a -> QueryJoin m a
liftQualify = m a -> QueryJoin m a
forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
join' (m a -> QueryJoin m a) -> (q a -> m a) -> q a -> QueryJoin m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. q a -> m a
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify

-- | Joinable query instance.
instance MonadQuery (QueryJoin ConfigureQuery) where
  setDuplication :: Duplication -> QueryJoin ConfigureQuery ()
setDuplication     = StateT JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
-> QueryJoin ConfigureQuery ()
forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin (StateT JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
 -> QueryJoin ConfigureQuery ())
-> (Duplication
    -> StateT
         JoinContext (WriterT (Last Duplication) ConfigureQuery) ())
-> Duplication
-> QueryJoin ConfigureQuery ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Last Duplication) ConfigureQuery ()
-> StateT
     JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Last Duplication) ConfigureQuery ()
 -> StateT
      JoinContext (WriterT (Last Duplication) ConfigureQuery) ())
-> (Duplication -> WriterT (Last Duplication) ConfigureQuery ())
-> Duplication
-> StateT
     JoinContext (WriterT (Last Duplication) ConfigureQuery) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last Duplication -> WriterT (Last Duplication) ConfigureQuery ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Last Duplication -> WriterT (Last Duplication) ConfigureQuery ())
-> (Duplication -> Last Duplication)
-> Duplication
-> WriterT (Last Duplication) ConfigureQuery ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Duplication -> Last Duplication
forall a. Maybe a -> Last a
Last (Maybe Duplication -> Last Duplication)
-> (Duplication -> Maybe Duplication)
-> Duplication
-> Last Duplication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Duplication -> Maybe Duplication
forall a. a -> Maybe a
Just
  restrictJoin :: Predicate Flat -> QueryJoin ConfigureQuery ()
restrictJoin       = Predicate Flat -> QueryJoin ConfigureQuery ()
forall (m :: * -> *). Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction
  query' :: Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
query'             = NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Just'
  queryMaybe' :: Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat (Maybe r))
queryMaybe' Relation p r
pr     = do
    (PlaceHolders p
ph, Record Flat r
pj) <- NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Maybe Relation p r
pr
    (PlaceHolders p, Record Flat (Maybe r))
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat (Maybe r))
forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders p
ph, Record Flat r -> Record Flat (Maybe r)
forall c r. Record c r -> Record c (Maybe r)
Record.just Record Flat r
pj)

-- | Unsafely join sub-query with this query.
unsafeSubQueryWithAttr :: MonadQualify ConfigureQuery q
                       => NodeAttr                 -- ^ Attribute maybe or just
                       -> Qualified SubQuery       -- ^ 'SubQuery' to join
                       -> QueryJoin q (Record c r) -- ^ Result joined context and record of 'SubQuery' result.
unsafeSubQueryWithAttr :: NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
unsafeSubQueryWithAttr NodeAttr
attr Qualified SubQuery
qsub = do
  Bool
addAS <- Config -> Bool
addQueryTableAliasAS (Config -> Bool) -> QueryJoin q Config -> QueryJoin q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualify (QueryConfig Identity) Config -> QueryJoin q Config
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify Qualify (QueryConfig Identity) Config
askConfig
  (JoinContext -> JoinContext) -> QueryJoin q ()
forall (m :: * -> *).
Monad m =>
(JoinContext -> JoinContext) -> QueryJoin m ()
updateContext ((Maybe (Node (DList (Predicate Flat)))
 -> Node (DList (Predicate Flat)))
-> JoinContext -> JoinContext
updateProduct (Maybe (Node (DList (Predicate Flat)))
-> (NodeAttr, (Bool, Qualified SubQuery))
-> Node (DList (Predicate Flat))
`growProduct` (NodeAttr
attr, (Bool
addAS, Qualified SubQuery
qsub))))
  Record c r -> QueryJoin q (Record c r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Record c r -> QueryJoin q (Record c r))
-> Record c r -> QueryJoin q (Record c r)
forall a b. (a -> b) -> a -> b
$ Qualified SubQuery -> Record c r
forall c t. Qualified SubQuery -> Record c t
Record.unsafeFromQualifiedSubQuery Qualified SubQuery
qsub

-- | Basic monadic join operation using 'MonadQuery'.
queryWithAttr :: NodeAttr
              -> Relation p r
              -> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr :: NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
attr = QueryJoin ConfigureQuery (Record c r)
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
forall (f :: * -> *) a p. Functor f => f a -> f (PlaceHolders p, a)
unsafeAddPlaceHolders (QueryJoin ConfigureQuery (Record c r)
 -> QueryJoin ConfigureQuery (PlaceHolders p, Record c r))
-> (Relation p r -> QueryJoin ConfigureQuery (Record c r))
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> QueryJoin ConfigureQuery (Record c r)
forall (q :: * -> *) p r c r.
MonadQualify ConfigureQuery q =>
Relation p r -> QueryJoin q (Record c r)
run where
  run :: Relation p r -> QueryJoin q (Record c r)
run Relation p r
rel = do
    Qualified SubQuery
q <- Qualify (QueryConfig Identity) (Qualified SubQuery)
-> QueryJoin q (Qualified SubQuery)
forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify (Qualify (QueryConfig Identity) (Qualified SubQuery)
 -> QueryJoin q (Qualified SubQuery))
-> Qualify (QueryConfig Identity) (Qualified SubQuery)
-> QueryJoin q (Qualified SubQuery)
forall a b. (a -> b) -> a -> b
$ do
      SubQuery
sq <- Relation p r -> ConfigureQuery SubQuery
forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation Relation p r
rel
      SubQuery -> Qualify (QueryConfig Identity) (Qualified SubQuery)
forall a. a -> ConfigureQuery (Qualified a)
qualifyQuery SubQuery
sq
    NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
forall (q :: * -> *) c r.
MonadQualify ConfigureQuery q =>
NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
unsafeSubQueryWithAttr NodeAttr
attr Qualified SubQuery
q

-- | Run 'QueryJoin' to get 'JoinProduct'
extractProduct :: Functor m => QueryJoin m a -> m ((a, JoinProduct), Duplication)
extractProduct :: QueryJoin m a -> m ((a, JoinProduct), Duplication)
extractProduct (QueryJoin StateT JoinContext (WriterT (Last Duplication) m) a
s) = ((JoinContext -> JoinProduct)
-> (a, JoinContext) -> (a, JoinProduct)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second JoinContext -> JoinProduct
joinProduct ((a, JoinContext) -> (a, JoinProduct))
-> (Last Duplication -> Duplication)
-> ((a, JoinContext), Last Duplication)
-> ((a, JoinProduct), Duplication)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Duplication -> Maybe Duplication -> Duplication
forall a. a -> Maybe a -> a
fromMaybe Duplication
All (Maybe Duplication -> Duplication)
-> (Last Duplication -> Maybe Duplication)
-> Last Duplication
-> Duplication
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last Duplication -> Maybe Duplication
forall a. Last a -> Maybe a
getLast))
                               (((a, JoinContext), Last Duplication)
 -> ((a, JoinProduct), Duplication))
-> m ((a, JoinContext), Last Duplication)
-> m ((a, JoinProduct), Duplication)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (Last Duplication) m (a, JoinContext)
-> m ((a, JoinContext), Last Duplication)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (StateT JoinContext (WriterT (Last Duplication) m) a
-> JoinContext -> WriterT (Last Duplication) m (a, JoinContext)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT JoinContext (WriterT (Last Duplication) m) a
s JoinContext
primeJoinContext)