module Database.Relational.Query.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.Query.Internal.BaseSQL (Assignment)
import Database.Relational.Query.Context (Flat)
import Database.Relational.Query.Pi (Pi)
import Database.Relational.Query.Table (Table, recordWidth)
import Database.Relational.Query.Projection (Projection)
import qualified Database.Relational.Query.Projection as Projection
import Database.Relational.Query.Monad.Class (MonadQualify (..), MonadRestrict(..))
newtype Assignings r m a =
Assignings (WriterT (Table r -> DList Assignment) m a)
deriving (MonadTrans, Monad, Functor, Applicative)
assignings :: Monad m => m a -> Assignings r m a
assignings = lift
instance MonadRestrict c m => MonadRestrict c (Assignings r m) where
restrict = assignings . restrict
instance MonadQualify q m => MonadQualify q (Assignings r m) where
liftQualify = assignings . liftQualify
type AssignTarget r v = Pi r v
targetProjection :: AssignTarget r v -> Table r -> Projection Flat v
targetProjection pi' tbl = Projection.wpi (recordWidth tbl) (Projection.unsafeFromTable tbl) pi'
assignTo :: Monad m => Projection Flat v -> AssignTarget r v -> Assignings r m ()
assignTo vp target = Assignings . tell
$ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where
leftsR = Projection.columns . targetProjection target
rights = Projection.columns vp
(<-#) :: Monad m => AssignTarget r v -> Projection Flat v -> Assignings r m ()
(<-#) = flip assignTo
infix 4 <-#
extractAssignments :: (Monad m, Functor m)
=> Assignings r m a
-> m (a, Table r -> [Assignment])
extractAssignments (Assignings ac) = second (toList .) <$> runWriterT ac