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

-- |
-- Module      : Database.Relational.Monad.Trans.Restricting
-- Copyright   : 2014-2017 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.Restricting (
  -- * Transformer into restricted context
  Restrictings, restrictings,

  -- * Result
  extractRestrict
  ) where

import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Control.Applicative (Applicative, pure, (<$>))
import Control.Arrow (second)
import Data.DList (DList, toList)

import Database.Relational.SqlSyntax (Predicate)

import Database.Relational.Monad.Class
  (MonadQualify (..), MonadRestrict(..), MonadQuery (..), MonadAggregate(..))


-- | Type to accumulate query restrictions.
--   Type 'c' is context tag of restriction building like
--   Flat (where) or Aggregated (having).
newtype Restrictings c m a =
  Restrictings (WriterT (DList (Predicate c)) m a)
  deriving (m a -> Restrictings c m a
(forall (m :: * -> *) a. Monad m => m a -> Restrictings c m a)
-> MonadTrans (Restrictings c)
forall c (m :: * -> *) a. Monad m => m a -> Restrictings c m a
forall (m :: * -> *) a. Monad m => m a -> Restrictings c m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> Restrictings c m a
$clift :: forall c (m :: * -> *) a. Monad m => m a -> Restrictings c m a
MonadTrans, Applicative (Restrictings c m)
a -> Restrictings c m a
Applicative (Restrictings c m)
-> (forall a b.
    Restrictings c m a
    -> (a -> Restrictings c m b) -> Restrictings c m b)
-> (forall a b.
    Restrictings c m a -> Restrictings c m b -> Restrictings c m b)
-> (forall a. a -> Restrictings c m a)
-> Monad (Restrictings c m)
Restrictings c m a
-> (a -> Restrictings c m b) -> Restrictings c m b
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
forall a. a -> Restrictings c m a
forall a b.
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
forall a b.
Restrictings c m a
-> (a -> Restrictings c m b) -> Restrictings c m b
forall c (m :: * -> *). Monad m => Applicative (Restrictings c m)
forall c (m :: * -> *) a. Monad m => a -> Restrictings c m a
forall c (m :: * -> *) a b.
Monad m =>
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
forall c (m :: * -> *) a b.
Monad m =>
Restrictings c m a
-> (a -> Restrictings c m b) -> Restrictings c 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 -> Restrictings c m a
$creturn :: forall c (m :: * -> *) a. Monad m => a -> Restrictings c m a
>> :: Restrictings c m a -> Restrictings c m b -> Restrictings c m b
$c>> :: forall c (m :: * -> *) a b.
Monad m =>
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
>>= :: Restrictings c m a
-> (a -> Restrictings c m b) -> Restrictings c m b
$c>>= :: forall c (m :: * -> *) a b.
Monad m =>
Restrictings c m a
-> (a -> Restrictings c m b) -> Restrictings c m b
$cp1Monad :: forall c (m :: * -> *). Monad m => Applicative (Restrictings c m)
Monad, a -> Restrictings c m b -> Restrictings c m a
(a -> b) -> Restrictings c m a -> Restrictings c m b
(forall a b. (a -> b) -> Restrictings c m a -> Restrictings c m b)
-> (forall a b. a -> Restrictings c m b -> Restrictings c m a)
-> Functor (Restrictings c m)
forall a b. a -> Restrictings c m b -> Restrictings c m a
forall a b. (a -> b) -> Restrictings c m a -> Restrictings c m b
forall c (m :: * -> *) a b.
Functor m =>
a -> Restrictings c m b -> Restrictings c m a
forall c (m :: * -> *) a b.
Functor m =>
(a -> b) -> Restrictings c m a -> Restrictings c m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Restrictings c m b -> Restrictings c m a
$c<$ :: forall c (m :: * -> *) a b.
Functor m =>
a -> Restrictings c m b -> Restrictings c m a
fmap :: (a -> b) -> Restrictings c m a -> Restrictings c m b
$cfmap :: forall c (m :: * -> *) a b.
Functor m =>
(a -> b) -> Restrictings c m a -> Restrictings c m b
Functor, Functor (Restrictings c m)
a -> Restrictings c m a
Functor (Restrictings c m)
-> (forall a. a -> Restrictings c m a)
-> (forall a b.
    Restrictings c m (a -> b)
    -> Restrictings c m a -> Restrictings c m b)
-> (forall a b c.
    (a -> b -> c)
    -> Restrictings c m a -> Restrictings c m b -> Restrictings c m c)
-> (forall a b.
    Restrictings c m a -> Restrictings c m b -> Restrictings c m b)
-> (forall a b.
    Restrictings c m a -> Restrictings c m b -> Restrictings c m a)
-> Applicative (Restrictings c m)
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
Restrictings c m a -> Restrictings c m b -> Restrictings c m a
Restrictings c m (a -> b)
-> Restrictings c m a -> Restrictings c m b
(a -> b -> c)
-> Restrictings c m a -> Restrictings c m b -> Restrictings c m c
forall a. a -> Restrictings c m a
forall a b.
Restrictings c m a -> Restrictings c m b -> Restrictings c m a
forall a b.
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
forall a b.
Restrictings c m (a -> b)
-> Restrictings c m a -> Restrictings c m b
forall a b c.
(a -> b -> c)
-> Restrictings c m a -> Restrictings c m b -> Restrictings c m c
forall c (m :: * -> *). Applicative m => Functor (Restrictings c m)
forall c (m :: * -> *) a. Applicative m => a -> Restrictings c m a
forall c (m :: * -> *) a b.
Applicative m =>
Restrictings c m a -> Restrictings c m b -> Restrictings c m a
forall c (m :: * -> *) a b.
Applicative m =>
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
forall c (m :: * -> *) a b.
Applicative m =>
Restrictings c m (a -> b)
-> Restrictings c m a -> Restrictings c m b
forall c (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> Restrictings c m a -> Restrictings c m b -> Restrictings c 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
<* :: Restrictings c m a -> Restrictings c m b -> Restrictings c m a
$c<* :: forall c (m :: * -> *) a b.
Applicative m =>
Restrictings c m a -> Restrictings c m b -> Restrictings c m a
*> :: Restrictings c m a -> Restrictings c m b -> Restrictings c m b
$c*> :: forall c (m :: * -> *) a b.
Applicative m =>
Restrictings c m a -> Restrictings c m b -> Restrictings c m b
liftA2 :: (a -> b -> c)
-> Restrictings c m a -> Restrictings c m b -> Restrictings c m c
$cliftA2 :: forall c (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> Restrictings c m a -> Restrictings c m b -> Restrictings c m c
<*> :: Restrictings c m (a -> b)
-> Restrictings c m a -> Restrictings c m b
$c<*> :: forall c (m :: * -> *) a b.
Applicative m =>
Restrictings c m (a -> b)
-> Restrictings c m a -> Restrictings c m b
pure :: a -> Restrictings c m a
$cpure :: forall c (m :: * -> *) a. Applicative m => a -> Restrictings c m a
$cp1Applicative :: forall c (m :: * -> *). Applicative m => Functor (Restrictings c m)
Applicative)

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

-- | Add whole query restriction.
updateRestriction :: Monad m => Predicate c -> Restrictings c m ()
updateRestriction :: Predicate c -> Restrictings c m ()
updateRestriction =  WriterT (DList (Predicate c)) m () -> Restrictings c m ()
forall c (m :: * -> *) a.
WriterT (DList (Predicate c)) m a -> Restrictings c m a
Restrictings (WriterT (DList (Predicate c)) m () -> Restrictings c m ())
-> (Predicate c -> WriterT (DList (Predicate c)) m ())
-> Predicate c
-> Restrictings c m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DList (Predicate c) -> WriterT (DList (Predicate c)) m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (DList (Predicate c) -> WriterT (DList (Predicate c)) m ())
-> (Predicate c -> DList (Predicate c))
-> Predicate c
-> WriterT (DList (Predicate c)) m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate c -> DList (Predicate c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | 'MonadRestrict' instance.
instance (Monad q, Functor q) => MonadRestrict c (Restrictings c q) where
  restrict :: Predicate c -> Restrictings c q ()
restrict = Predicate c -> Restrictings c q ()
forall (m :: * -> *) c.
Monad m =>
Predicate c -> Restrictings c m ()
updateRestriction

-- | Restricted 'MonadQualify' instance.
instance MonadQualify q m => MonadQualify q (Restrictings c m) where
  liftQualify :: q a -> Restrictings c m a
liftQualify = m a -> Restrictings c m a
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (m a -> Restrictings c m a)
-> (q a -> m a) -> q a -> Restrictings c 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

-- | Restricted 'MonadQuery' instance.
instance MonadQuery q => MonadQuery (Restrictings c q) where
  setDuplication :: Duplication -> Restrictings c q ()
setDuplication     = q () -> Restrictings c q ()
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (q () -> Restrictings c q ())
-> (Duplication -> q ()) -> Duplication -> Restrictings c q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Duplication -> q ()
forall (m :: * -> *). MonadQuery m => Duplication -> m ()
setDuplication
  restrictJoin :: Predicate Flat -> Restrictings c q ()
restrictJoin       = q () -> Restrictings c q ()
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (q () -> Restrictings c q ())
-> (Predicate Flat -> q ())
-> Predicate Flat
-> Restrictings c q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate Flat -> q ()
forall (m :: * -> *). MonadQuery m => Predicate Flat -> m ()
restrictJoin
  query' :: Relation p r -> Restrictings c q (PlaceHolders p, Record Flat r)
query'             = q (PlaceHolders p, Record Flat r)
-> Restrictings c q (PlaceHolders p, Record Flat r)
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (q (PlaceHolders p, Record Flat r)
 -> Restrictings c q (PlaceHolders p, Record Flat r))
-> (Relation p r -> q (PlaceHolders p, Record Flat r))
-> Relation p r
-> Restrictings c q (PlaceHolders p, Record Flat r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> q (PlaceHolders p, Record Flat r)
forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat r)
query'
  queryMaybe' :: Relation p r
-> Restrictings c q (PlaceHolders p, Record Flat (Maybe r))
queryMaybe'        = q (PlaceHolders p, Record Flat (Maybe r))
-> Restrictings c q (PlaceHolders p, Record Flat (Maybe r))
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (q (PlaceHolders p, Record Flat (Maybe r))
 -> Restrictings c q (PlaceHolders p, Record Flat (Maybe r)))
-> (Relation p r -> q (PlaceHolders p, Record Flat (Maybe r)))
-> Relation p r
-> Restrictings c q (PlaceHolders p, Record Flat (Maybe r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relation p r -> q (PlaceHolders p, Record Flat (Maybe r))
forall (m :: * -> *) p r.
MonadQuery m =>
Relation p r -> m (PlaceHolders p, Record Flat (Maybe r))
queryMaybe'

-- | Resticted 'MonadAggregate' instance.
instance MonadAggregate m => MonadAggregate (Restrictings c m) where
  groupBy :: Record Flat r -> Restrictings c m (Record Aggregated r)
groupBy  = m (Record Aggregated r) -> Restrictings c m (Record Aggregated r)
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (m (Record Aggregated r) -> Restrictings c m (Record Aggregated r))
-> (Record Flat r -> m (Record Aggregated r))
-> Record Flat r
-> Restrictings c m (Record Aggregated r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record Flat r -> m (Record Aggregated r)
forall (m :: * -> *) r.
MonadAggregate m =>
Record Flat r -> m (Record Aggregated r)
groupBy
  groupBy' :: AggregateKey (Record Aggregated r)
-> Restrictings c m (Record Aggregated r)
groupBy' = m (Record Aggregated r) -> Restrictings c m (Record Aggregated r)
forall (m :: * -> *) a c. Monad m => m a -> Restrictings c m a
restrictings (m (Record Aggregated r) -> Restrictings c m (Record Aggregated r))
-> (AggregateKey (Record Aggregated r) -> m (Record Aggregated r))
-> AggregateKey (Record Aggregated r)
-> Restrictings c m (Record Aggregated r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AggregateKey (Record Aggregated r) -> m (Record Aggregated r)
forall (m :: * -> *) r.
MonadAggregate m =>
AggregateKey (Record Aggregated r) -> m (Record Aggregated r)
groupBy'

-- | Run 'Restrictings' to get 'QueryRestriction'
extractRestrict :: (Monad m, Functor m) => Restrictings c m a -> m (a, [Predicate c])
extractRestrict :: Restrictings c m a -> m (a, [Predicate c])
extractRestrict (Restrictings WriterT (DList (Predicate c)) m a
rc) = (DList (Predicate c) -> [Predicate c])
-> (a, DList (Predicate c)) -> (a, [Predicate c])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second DList (Predicate c) -> [Predicate c]
forall a. DList a -> [a]
toList ((a, DList (Predicate c)) -> (a, [Predicate c]))
-> m (a, DList (Predicate c)) -> m (a, [Predicate c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (DList (Predicate c)) m a -> m (a, DList (Predicate c))
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (DList (Predicate c)) m a
rc