@@ -12,6 +12,7 @@ import qualified Data.Vector as V
1212import ProjectM36.Error
1313import ProjectM36.Relation
1414import qualified Control.Monad.IO.Class as Trans
15+import Control.Monad.Trans.Class
1516import Control.Monad.Trans.Reader (ask, ReaderT)
1617import Control.Exception (throw, throwIO)
1718import qualified Data.Text as T
@@ -440,7 +441,17 @@ updateToUpdateTuple up@(DPT.Update field value op) = let entDef = entityDef $ du
440441 Nothing -> Left $ AtomTypeNotSupported attrName
441442 Just atom' -> Right $ (attrName, atom')
442443 op' -> Left $ AtomOperatorNotSupported $ T.pack (show op')
443−
444+
445+selectionFromRestriction :: (PersistEntity val, PersistEntityBackend val ~ backend, Trans.MonadIO m, backend ~ C.Connection) => [Filter val] -> ReaderT backend m (Either RelationalError RelationalExpr)
446+selectionFromRestriction filters = do
447+ conn <- ask
448+ runEitherT $ do
449+ restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
450+ let entDef = entityDef $ dummyFromFilters filters
451+ relVarName = unDBName $ entityDB entDef
452+ right $ Restrict restrictionPredicate (RelationVariable relVarName)
453+
454+
444455instance PersistQuery C.Connection where
445456 updateWhere _ [] = return ()
446457 updateWhere filters updates = do
@@ -504,11 +515,10 @@ instance PersistQuery C.Connection where
504515 selectSourceRes filters [] = do
505516 conn <- ask
506517 entities <- runEitherT $ do
507− restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
508− let entDef = entityDef $ dummyFromFilters filters
509− relVarName = unDBName $ entityDB entDef
510− restrictionExpr = Restrict restrictionPredicate (RelationVariable relVarName)
511− tupleMapper tuple = Trans.liftIO $ fromPersistValuesThrow entDef tuple
518+ restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither
519+ --restrictionExpr' <- hoistEither restrictionExpr
520+ let entDef = entityDef $ dummyFromFilters filters
521+ let tupleMapper tuple = Trans.liftIO $ fromPersistValuesThrow entDef tuple
512522 rel <- Trans.liftIO $ C.executeRelationalExpr conn restrictionExpr
513523 case rel of
514524 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack (show err))
@@ -517,4 +527,23 @@ instance PersistQuery C.Connection where
517527 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack $ show err)
518528 Right entities' -> return $ return $ CL.sourceList entities'
519529
520− selectKeysRes = undefined
530+ selectKeysRes _ (_:_) = Trans.liftIO $ throwIO $ PersistError "select options not yet supported"
531+ selectKeysRes filters [] = do
532+ conn <- ask
533+ keys <- runEitherT $ do
534+ restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither
535+ let entDef = entityDef $ dummyFromFilters filters
536+ keyAttrNames = ["id"] --no support for multi-attribute keys yet
537+ keyExpr = Project (AttributeNames $ S.fromList keyAttrNames) restrictionExpr
538+ (Relation _ tupleSet) <- (Trans.liftIO $ C.executeRelationalExpr conn keyExpr) >>= hoistEither
539+ let keyMapper :: (PersistEntity record, Trans.MonadIO m) => RelationTuple -> EitherT RelationalError (ReaderT C.Connection m) (Key record)
540+ keyMapper tuple = do
541+ atoms <- hoistEither (atomsForAttributeNames (V.fromList keyAttrNames) tuple)
542+ case keyFromValues (map atomAsPersistValue (V.toList atoms)) of
543+ Left err -> Trans.liftIO $ throwIO $ PersistError "keyFromValues failure"
544+ Right key -> right key
545+ mapM keyMapper $ HS.toList tupleSet
546+ case keys of
547+ Left err -> Trans.liftIO $ throwIO $ PersistError "keyFromValues failure2"
548+ Right keys' -> return $ return (CL.sourceList keys')
549+