{-# 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 (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 :: forall a. a -> QueryJoin m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
>> :: forall a b. 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
>>= :: forall a 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
Monad, 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
<$ :: forall a b. a -> QueryJoin m b -> QueryJoin m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> QueryJoin m b -> QueryJoin m a
fmap :: forall a b. (a -> b) -> QueryJoin m a -> QueryJoin m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> QueryJoin m a -> QueryJoin m b
Functor, 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
<* :: forall a b. 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
*> :: forall a b. 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 :: forall a b c.
(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
<*> :: forall a b. 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 :: forall a. a -> QueryJoin m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> QueryJoin m a
Applicative)

instance MonadTrans QueryJoin where
  lift :: forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
lift = forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' :: forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
join' = 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 :: forall (m :: * -> *).
Monad m =>
(JoinContext -> JoinContext) -> QueryJoin m ()
updateContext =  forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify

-- | Add last join product restriction.
updateJoinRestriction :: Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction :: forall (m :: * -> *). Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction Predicate Flat
e = 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  = 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 :: forall a. q a -> QueryJoin m a
liftQualify = forall (m :: * -> *) a. Monad m => m a -> QueryJoin m a
join' forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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     = forall (m :: * -> *) a.
StateT JoinContext (WriterT (Last Duplication) m) a
-> QueryJoin m a
QueryJoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Last a
Last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
  restrictJoin :: Predicate Flat -> QueryJoin ConfigureQuery ()
restrictJoin       = forall (m :: * -> *). Monad m => Predicate Flat -> QueryJoin m ()
updateJoinRestriction
  query' :: forall p r.
Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat r)
query'             = forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Just'
  queryMaybe' :: forall p r.
Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record Flat (Maybe r))
queryMaybe' Relation p r
pr     = do
    (PlaceHolders p
ph, Record Flat r
pj) <- forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
Maybe Relation p r
pr
    forall (m :: * -> *) a. Monad m => a -> m a
return (PlaceHolders p
ph, 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 :: forall (q :: * -> *) c r.
MonadQualify ConfigureQuery q =>
NodeAttr -> Qualified SubQuery -> QueryJoin q (Record c r)
unsafeSubQueryWithAttr NodeAttr
attr Qualified SubQuery
qsub = do
  Bool
addAS <- Config -> Bool
addQueryTableAliasAS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify ConfigureQuery Config
askConfig
  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))))
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall p r c.
NodeAttr
-> Relation p r
-> QueryJoin ConfigureQuery (PlaceHolders p, Record c r)
queryWithAttr NodeAttr
attr = forall (f :: * -> *) a p. Functor f => f a -> f (PlaceHolders p, a)
unsafeAddPlaceHolders forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (q :: * -> *) (m :: * -> *) a.
MonadQualify q m =>
q a -> m a
liftQualify forall a b. (a -> b) -> a -> b
$ do
      SubQuery
sq <- forall p r. Relation p r -> ConfigureQuery SubQuery
untypeRelation Relation p r
rel
      forall a. a -> ConfigureQuery (Qualified a)
qualifyQuery SubQuery
sq
    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 :: forall (m :: * -> *) a.
Functor m =>
QueryJoin m a -> m ((a, JoinProduct), Duplication)
extractProduct (QueryJoin StateT JoinContext (WriterT (Last Duplication) m) a
s) = (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second JoinContext -> JoinProduct
joinProduct forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (forall a. a -> Maybe a -> a
fromMaybe Duplication
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Last a -> Maybe a
getLast))
                               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT JoinContext (WriterT (Last Duplication) m) a
s JoinContext
primeJoinContext)