{-# 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 (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 :: forall (m :: * -> *) a. Monad m => m a -> Assignings r m a
$clift :: forall r (m :: * -> *) a. Monad m => m a -> Assignings r m a
MonadTrans, 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 :: forall a. a -> Assignings r m a
$creturn :: forall r (m :: * -> *) a. Monad m => a -> Assignings r m a
>> :: forall a b.
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
>>= :: forall a 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
Monad, 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
<$ :: forall a b. 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 :: forall a b. (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, 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
<* :: forall a b.
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
*> :: forall a b.
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 :: forall a b c.
(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
<*> :: forall a b.
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 :: forall a. a -> Assignings r m a
$cpure :: forall r (m :: * -> *) a. Applicative m => a -> Assignings r m a
Applicative)

-- | Lift to 'Assignings'
assignings :: Monad m => m a -> Assignings r m a
assignings :: forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings =  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 = forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (m :: * -> *). MonadRestrict c m => Predicate c -> m ()
restrict

-- | 'MonadQualify' with assigning.
instance MonadQualify q m => MonadQualify q (Assignings r m) where
  liftQualify :: forall a. q a -> Assignings r m a
liftQualify = forall (m :: * -> *) a r. Monad m => m a -> Assignings r m a
assignings forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall r v. AssignTarget r v -> Table r -> Record Flat v
targetRecord AssignTarget r v
pi' Table r
tbl = forall a c b.
PersistableRecordWidth a -> Record c a -> Pi a b -> Record c b
Record.wpi (forall r. Table r -> PersistableRecordWidth r
recordWidth Table r
tbl) (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 :: forall (m :: * -> *) v r.
Monad m =>
Record Flat v -> AssignTarget r v -> Assignings r m ()
assignTo Record Flat v
vp AssignTarget r v
target = forall r (m :: * -> *) a.
WriterT (Table r -> DList Assignment) m a -> Assignings r m a
Assignings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell
                     forall a b. (a -> b) -> a -> b
$ \Table r
t -> forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall (f :: * -> *) a. Applicative f => a -> f a
pure) (Table r -> [StringSQL]
leftsR Table r
t) [StringSQL]
rights  where
  leftsR :: Table r -> [StringSQL]
leftsR = forall c r. Record c r -> [StringSQL]
Record.columns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r v. AssignTarget r v -> Table r -> Record Flat v
targetRecord AssignTarget r v
target
  rights :: [StringSQL]
rights = forall c r. Record c r -> [StringSQL]
Record.columns Record Flat v
vp

-- | Add and assignment.
(<-#) :: Monad m => AssignTarget r v -> Record Flat v -> Assignings r m ()
<-# :: forall (m :: * -> *) r v.
Monad m =>
AssignTarget r v -> Record Flat v -> Assignings r m ()
(<-#) =  forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: forall (m :: * -> *) r a.
(Monad m, Functor m) =>
Assignings r m a -> m (a, Table r -> [Assignment])
extractAssignments (Assignings WriterT (Table r -> DList Assignment) m a
ac) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall a. DList a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT (Table r -> DList Assignment) m a
ac