{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Database.Relational.Monad.Trans.Assigning (
Assignings, assignings,
assignTo, (<-#), AssignTarget,
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(..))
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)
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
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
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
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'
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
(<-#) :: 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 <-#
extractAssignments :: (Monad m, Functor m)
=> Assignings r m a
-> m (a, Table r -> [Assignment])
(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