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

-- |
-- Module      : Database.Relational.Monad.Trans.Assigning
-- Copyright   : 2013-2019 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines monad transformer which lift
-- from context into context with assigning.
module Database.Relational.Monad.Trans.Assigning (
  -- * Transformer into context with assignments
  Assignings, assignings,

  -- * API of context with assignments
  assignTo, (<-#), AssignTarget,

  -- * Result SQL set clause
  extractAssignments
  ) 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.Monoid (mconcat)
import Data.DList (DList, toList)

import Database.Relational.Internal.ContextType (Flat)
import Database.Relational.SqlSyntax (Record, Assignment)

import Database.Relational.Pi (Pi)
import Database.Relational.Table (Table, recordWidth)
import qualified Database.Relational.Record as Record
import Database.Relational.Monad.Class (MonadQualify (..), MonadRestrict(..))


-- | Type to accumulate assigning context.
--   Type 'r' is table record type.
newtype Assignings r m a =
  Assignings (WriterT (Table r -> DList Assignment) m a)
  deriving (m a -> Assignings r m a
(forall (m :: * -> *) a. Monad m => m a -> Assignings r m a)
-> MonadTrans (Assignings r)
forall r (m :: * -> *) a. Monad m => m a -> Assignings r m a
forall (m :: * -> *) a. Monad m => m a -> Assignings r m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> Assignings r m a
$clift :: forall r (m :: * -> *) a. Monad m => m a -> Assignings r m a
MonadTrans, Applicative (Assignings r m)
a -> Assignings r m a
Applicative (Assignings r m)
-> (forall a b.
    Assignings r m a -> (a -> Assignings r m b) -> Assignings r m b)
-> (forall a b.
    Assignings r m a -> Assignings r m b -> Assignings r m b)
-> (forall a. a -> Assignings r m a)
-> Monad (Assignings r m)
Assignings r m a -> (a -> Assignings r m b) -> Assignings r m b
Assignings r m a -> Assignings r m b -> Assignings r m b
forall a. a -> Assignings r m a
forall a b.
Assignings r m a -> Assignings r m b -> Assignings r m b
forall a b.
Assignings r m a -> (a -> Assignings r m b) -> Assignings r m b
forall r (m :: * -> *). Monad m => Applicative (Assignings r m)
forall r (m :: * -> *) a. Monad m => a -> Assignings r m a
forall r (m :: * -> *) a b.
Monad m =>
Assignings r m a -> Assignings r m b -> Assignings r m b
forall r (m :: * -> *) a b.
Monad m =>
Assignings r m a -> (a -> Assignings r m b) -> Assignings r 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 -> Assignings r m a
$creturn :: forall r (m :: * -> *) a. Monad m => a -> Assignings r m a
>> :: Assignings r m a -> Assignings r m b -> Assignings r m b
$c>> :: forall r (m :: * -> *) a b.
Monad m =>
Assignings r m a -> Assignings r m b -> Assignings r m b
>>= :: Assignings r m a -> (a -> Assignings r m b) -> Assignings r m b
$c>>= :: forall r (m :: * -> *) a b.
Monad m =>
Assignings r m a -> (a -> Assignings r m b) -> Assignings r m b
$cp1Monad :: forall r (m :: * -> *). Monad m => Applicative (Assignings r m)
Monad, a -> Assignings r m b -> Assignings r m a
(a -> b) -> Assignings r m a -> Assignings r m b
(forall a b. (a -> b) -> Assignings r m a -> Assignings r m b)
-> (forall a b. a -> Assignings r m b -> Assignings r m a)
-> Functor (Assignings r m)
forall a b. a -> Assignings r m b -> Assignings r m a
forall a b. (a -> b) -> Assignings r m a -> Assignings r m b
forall r (m :: * -> *) a b.
Functor m =>
a -> Assignings r m b -> Assignings r m a
forall r (m :: * -> *) a b.
Functor m =>
(a -> b) -> Assignings r m a -> Assignings r m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Assignings r m b -> Assignings r m a
$c<$ :: forall r (m :: * -> *) a b.
Functor m =>
a -> Assignings r m b -> Assignings r m a
fmap :: (a -> b) -> Assignings r m a -> Assignings r m b
$cfmap :: forall r (m :: * -> *) a b.
Functor m =>
(a -> b) -> Assignings r m a -> Assignings r m b
Functor, Functor (Assignings r m)
a -> Assignings r m a
Functor (Assignings r m)
-> (forall a. a -> Assignings r m a)
-> (forall a b.
    Assignings r m (a -> b) -> Assignings r m a -> Assignings r m b)
-> (forall a b c.
    (a -> b -> c)
    -> Assignings r m a -> Assignings r m b -> Assignings r m c)
-> (forall a b.
    Assignings r m a -> Assignings r m b -> Assignings r m b)
-> (forall a b.
    Assignings r m a -> Assignings r m b -> Assignings r m a)
-> Applicative (Assignings r m)
Assignings r m a -> Assignings r m b -> Assignings r m b
Assignings r m a -> Assignings r m b -> Assignings r m a
Assignings r m (a -> b) -> Assignings r m a -> Assignings r m b
(a -> b -> c)
-> Assignings r m a -> Assignings r m b -> Assignings r m c
forall a. a -> Assignings r m a
forall a b.
Assignings r m a -> Assignings r m b -> Assignings r m a
forall a b.
Assignings r m a -> Assignings r m b -> Assignings r m b
forall a b.
Assignings r m (a -> b) -> Assignings r m a -> Assignings r m b
forall a b c.
(a -> b -> c)
-> Assignings r m a -> Assignings r m b -> Assignings r m c
forall r (m :: * -> *). Applicative m => Functor (Assignings r m)
forall r (m :: * -> *) a. Applicative m => a -> Assignings r m a
forall r (m :: * -> *) a b.
Applicative m =>
Assignings r m a -> Assignings r m b -> Assignings r m a
forall r (m :: * -> *) a b.
Applicative m =>
Assignings r m a -> Assignings r m b -> Assignings r m b
forall r (m :: * -> *) a b.
Applicative m =>
Assignings r m (a -> b) -> Assignings r m a -> Assignings r m b
forall r (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> Assignings r m a -> Assignings r m b -> Assignings r 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
<* :: Assignings r m a -> Assignings r m b -> Assignings r m a
$c<* :: forall r (m :: * -> *) a b.
Applicative m =>
Assignings r m a -> Assignings r m b -> Assignings r m a
*> :: Assignings r m a -> Assignings r m b -> Assignings r m b
$c*> :: forall r (m :: * -> *) a b.
Applicative m =>
Assignings r m a -> Assignings r m b -> Assignings r m b
liftA2 :: (a -> b -> c)
-> Assignings r m a -> Assignings r m b -> Assignings r m c
$cliftA2 :: forall r (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> Assignings r m a -> Assignings r m b -> Assignings r m c
<*> :: Assignings r m (a -> b) -> Assignings r m a -> Assignings r m b
$c<*> :: forall r (m :: * -> *) a b.
Applicative m =>
Assignings r m (a -> b) -> Assignings r m a -> Assignings r m b
pure :: a -> Assignings r m a
$cpure :: forall r (m :: * -> *) a. Applicative m => a -> Assignings r m a
$cp1Applicative :: forall r (m :: * -> *). Applicative m => Functor (Assignings r m)
Applicative)

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

-- | 'MonadRestrict' with assigning.
instance MonadRestrict c m => MonadRestrict c (Assignings r m) where
  restrict :: Predicate c -> Assignings r m ()
restrict = m () -> Assignings r m ()
forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings (m () -> Assignings r m ())
-> (Predicate c -> m ()) -> Predicate c -> Assignings r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate c -> m ()
forall c (m :: * -> *). MonadRestrict c m => Predicate c -> m ()
restrict

-- | 'MonadQualify' with assigning.
instance MonadQualify q m => MonadQualify q (Assignings r m) where
  liftQualify :: q a -> Assignings r m a
liftQualify = m a -> Assignings r m a
forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings (m a -> Assignings r m a)
-> (q a -> m a) -> q a -> Assignings r 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

-- | Target of assignment.
type AssignTarget r v = Pi r v

targetRecord :: AssignTarget r v ->  Table r -> Record Flat v
targetRecord :: AssignTarget r v -> Table r -> Record Flat v
targetRecord AssignTarget r v
pi' Table r
tbl = PersistableRecordWidth r
-> Record Flat r -> AssignTarget r v -> Record Flat v
forall a c b.
PersistableRecordWidth a -> Record c a -> Pi a b -> Record c b
Record.wpi (Table r -> PersistableRecordWidth r
forall r. Table r -> PersistableRecordWidth r
recordWidth Table r
tbl) (Table r -> Record Flat r
forall r c. Table r -> Record c r
Record.unsafeFromTable Table r
tbl) AssignTarget r v
pi'

-- | Add an assignment.
assignTo :: Monad m => Record Flat v ->  AssignTarget r v -> Assignings r m ()
assignTo :: Record Flat v -> AssignTarget r v -> Assignings r m ()
assignTo Record Flat v
vp AssignTarget r v
target = WriterT (Table r -> DList Assignment) m () -> Assignings r m ()
forall r (m :: * -> *) a.
WriterT (Table r -> DList Assignment) m a -> Assignings r m a
Assignings (WriterT (Table r -> DList Assignment) m () -> Assignings r m ())
-> ((Table r -> DList Assignment)
    -> WriterT (Table r -> DList Assignment) m ())
-> (Table r -> DList Assignment)
-> Assignings r m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Table r -> DList Assignment)
-> WriterT (Table r -> DList Assignment) m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell
                     ((Table r -> DList Assignment) -> Assignings r m ())
-> (Table r -> DList Assignment) -> Assignings r m ()
forall a b. (a -> b) -> a -> b
$ \Table r
t -> [DList Assignment] -> DList Assignment
forall a. Monoid a => [a] -> a
mconcat ([DList Assignment] -> DList Assignment)
-> [DList Assignment] -> DList Assignment
forall a b. (a -> b) -> a -> b
$ (StringSQL -> StringSQL -> DList Assignment)
-> [StringSQL] -> [StringSQL] -> [DList Assignment]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((Assignment -> DList Assignment)
-> StringSQL -> StringSQL -> DList Assignment
forall a b c. ((a, b) -> c) -> a -> b -> c
curry Assignment -> DList Assignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Table r -> [StringSQL]
leftsR Table r
t) [StringSQL]
rights  where
  leftsR :: Table r -> [StringSQL]
leftsR = Record Flat v -> [StringSQL]
forall c r. Record c r -> [StringSQL]
Record.columns (Record Flat v -> [StringSQL])
-> (Table r -> Record Flat v) -> Table r -> [StringSQL]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AssignTarget r v -> Table r -> Record Flat v
forall r v. AssignTarget r v -> Table r -> Record Flat v
targetRecord AssignTarget r v
target
  rights :: [StringSQL]
rights = Record Flat v -> [StringSQL]
forall c r. Record c r -> [StringSQL]
Record.columns Record Flat v
vp

-- | Add and assginment.
(<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# :: AssignTarget r v -> Record Flat v -> Assignings r m ()
(<-#) =  (Record Flat v -> AssignTarget r v -> Assignings r m ())
-> AssignTarget r v -> Record Flat v -> Assignings r m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Record Flat v -> AssignTarget r v -> Assignings r m ()
forall (m :: * -> *) v r.
Monad m =>
Record Flat v -> AssignTarget r v -> Assignings r m ()
assignTo

infix 4 <-#

-- | Run 'Assignings' to get ['Assignment']
extractAssignments :: (Monad m, Functor m)
                   => Assignings r m a
                   -> m (a, Table r -> [Assignment])
extractAssignments :: Assignings r m a -> m (a, Table r -> [Assignment])
extractAssignments (Assignings WriterT (Table r -> DList Assignment) m a
ac) = ((Table r -> DList Assignment) -> Table r -> [Assignment])
-> (a, Table r -> DList Assignment) -> (a, Table r -> [Assignment])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (DList Assignment -> [Assignment]
forall a. DList a -> [a]
toList (DList Assignment -> [Assignment])
-> (Table r -> DList Assignment) -> Table r -> [Assignment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a, Table r -> DList Assignment) -> (a, Table r -> [Assignment]))
-> m (a, Table r -> DList Assignment)
-> m (a, Table r -> [Assignment])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (Table r -> DList Assignment) m a
-> m (a, Table r -> DList Assignment)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (Table r -> DList Assignment) m a
ac