@@ -12,6 +12,7 @@ import qualified Data.Vector as V
12import ProjectM36.Error
12import ProjectM36.Error
13import ProjectM36.Relation
13import ProjectM36.Relation
14import qualified Control.Monad.IO.Class as Trans
14import qualified Control.Monad.IO.Class as Trans
15+import Control.Monad.Trans.Class
15import Control.Monad.Trans.Reader (ask, ReaderT)
16import Control.Monad.Trans.Reader (ask, ReaderT)
16import Control.Exception (throw, throwIO)
17import Control.Exception (throw, throwIO)
17import qualified Data.Text as T
18import qualified Data.Text as T
@@ -440,7 +441,17 @@ updateToUpdateTuple up@(DPT.Update field value op) = let entDef = entityDef $ du
440 Nothing -> Left $ AtomTypeNotSupported attrName
441 Nothing -> Left $ AtomTypeNotSupported attrName
441 Just atom' -> Right $ (attrName, atom')
442 Just atom' -> Right $ (attrName, atom')
442 op' -> Left $ AtomOperatorNotSupported $ T.pack (show op')
443 op' -> Left $ AtomOperatorNotSupported $ T.pack (show op')
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
449+ restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
450+ let entDef = entityDef $ dummyFromFilters filters
451+ relVarName = unDBName $ entityDB entDef
452+ right $ Restrict restrictionPredicate (RelationVariable relVarName)
444instance PersistQuery C.Connection where
455instance PersistQuery C.Connection where
445 updateWhere _ [] = return ()
456 updateWhere _ [] = return ()
446 updateWhere filters updates = do
457 updateWhere filters updates = do
@@ -504,11 +515,10 @@ instance PersistQuery C.Connection where
504 selectSourceRes filters [] = do
515 selectSourceRes filters [] = do
505 conn <- ask
516 conn <- ask
506 entities <- runEitherT $ do
517 entities <- runEitherT $ do
507− restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters
518+ restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither
519+ --restrictionExpr' <- hoistEither restrictionExpr
508− let entDef = entityDef $ dummyFromFilters filters
520+ let entDef = entityDef $ dummyFromFilters filters
509− relVarName = unDBName $ entityDB entDef
510− restrictionExpr = Restrict restrictionPredicate (RelationVariable relVarName)
511− tupleMapper tuple = Trans.liftIO $ fromPersistValuesThrow entDef tuple
521+ let tupleMapper tuple = Trans.liftIO $ fromPersistValuesThrow entDef tuple
512 rel <- Trans.liftIO $ C.executeRelationalExpr conn restrictionExpr
522 rel <- Trans.liftIO $ C.executeRelationalExpr conn restrictionExpr
513 case rel of
523 case rel of
514 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack (show err))
524 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack (show err))
@@ -517,4 +527,23 @@ instance PersistQuery C.Connection where
517 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack $ show err)
527 Left err -> Trans.liftIO $ throwIO $ PersistError (T.pack $ show err)
518 Right entities' -> return $ return $ CL.sourceList entities'
528 Right entities' -> return $ return $ CL.sourceList entities'
520− selectKeysRes = undefined
530+ selectKeysRes _ (_:_) = Trans.liftIO $ throwIO $ PersistError "select options not yet supported"
531+ selectKeysRes filters [] = do
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
547+ Left err -> Trans.liftIO $ throwIO $ PersistError "keyFromValues failure2"
548+ Right keys' -> return $ return (CL.sourceList keys')