{-# 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 (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)
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
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
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
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'
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
(<-#) :: 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 <-#
extractAssignments :: (Monad m, Functor m)
=> Assignings r m a
-> m (a, Table r -> [Assignment])
(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