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 (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
targetRecord :: AssignTarget r v -> Table r -> Record Flat v
targetRecord pi' tbl = Record.wpi (recordWidth tbl) (Record.unsafeFromTable tbl) pi'
assignTo :: Monad m => Record Flat v -> AssignTarget r v -> Assignings r m ()
assignTo vp target = Assignings . tell
$ \t -> mconcat $ zipWith (curry pure) (leftsR t) rights where
leftsR = Record.columns . targetRecord target
rights = Record.columns vp
(<-#) :: Monad m => AssignTarget r v -> Record 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