ccfd852 · project-m36 · git.iko.soy

git.iko.soy/project-m36

on master help sign in

fix loads of unused name warnings in persistent driver

ccfd852AgentM11 years ago

Database/Persist/ProjectM36.hs+26−29

compare with master

unifiedsplit

@@ -18,7 +18,6 @@ import Control.Exception (throw, throwIO)

18import qualified Data.Text as T

19import ProjectM36.Atom

20import Data.Aeson (FromJSON(..), ToJSON(..), withText, withObject, (.:))

21−import qualified Data.HashSet as HS

22import qualified Data.Map as M

21import qualified Data.Map as M

23import Control.Monad (when)

22import Control.Monad (when)

24import Data.Maybe (isJust)

23import Data.Maybe (isJust)

@@ -27,7 +26,6 @@ import Control.Monad.Reader (runReaderT)

27import Web.PathPieces (PathPiece (..))

26import Web.PathPieces (PathPiece (..))

28import qualified Database.Persist.Sql as Sql

27import qualified Database.Persist.Sql as Sql

29import Control.Monad.Trans.Either

28import Control.Monad.Trans.Either

30−import Database.Persist.Class

31import qualified Database.Persist.Types as DPT

29import qualified Database.Persist.Types as DPT

32import qualified Data.Set as S

30import qualified Data.Set as S

33import qualified Data.Conduit.List as CL

31import qualified Data.Conduit.List as CL

@@ -123,7 +121,10 @@ insertNewRecords uuids records = do

123 conn <- ask

121 conn <- ask

124 Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))

122 Trans.liftIO $ executeDatabaseContextExpr conn (insertExpr (ExistingRelation rel))

125 mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids

123 mapM (\uuid -> keyFromValuesOrDie [PersistText $ T.pack (U.toString uuid)]) uuids

126−

124+

125+throwIOPersistError :: (Trans.MonadIO m) => String -> m a

126+throwIOPersistError msg = Trans.liftIO $ throwIO $ PersistError (T.pack msg)

127+

127lookupByKey :: forall record m.

128lookupByKey :: forall record m.

128 (Trans.MonadIO m,

129 (Trans.MonadIO m,

129 PersistEntity record,

130 PersistEntity record,

@@ -135,7 +136,7 @@ lookupByKey key = do

135 conn <- ask

136 conn <- ask

136 resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query

137 resultRel <- Trans.liftIO $ C.executeRelationalExpr conn query

137 case resultRel of

138 case resultRel of

138− Left err -> Trans.liftIO $ throwIO $ PersistError "executeRelationExpr error"

139+ Left err -> throwIOPersistError ("executeRelationExpr error: " ++ show err)

139 Right resultRel' -> case singletonTuple resultRel' of

140 Right resultRel' -> case singletonTuple resultRel' of

140 Nothing -> return Nothing --no match on key

141 Nothing -> return Nothing --no match on key

141 Just tuple -> do

142 Just tuple -> do

@@ -150,14 +151,14 @@ fromPersistValuesThrow entDef tuple = do

150 let body = fromPersistValues $ map getValue (entityFields entDef)

151 let body = fromPersistValues $ map getValue (entityFields entDef)

151 getValue field = case atomForAttributeName (unDBName (fieldDB field)) tuple of

152 getValue field = case atomForAttributeName (unDBName (fieldDB field)) tuple of

152 Right atom -> atomAsPersistValue atom

153 Right atom -> atomAsPersistValue atom

153− Left err -> throw $ PersistError "missing field"

154+ Left err -> throw $ PersistError ("missing field: " `T.append` (T.pack $ show err))

154 keyAtom = atomForAttributeName (unDBName (fieldDB (entityId entDef))) tuple

155 keyAtom = atomForAttributeName (unDBName (fieldDB (entityId entDef))) tuple

155 case keyAtom of

156 case keyAtom of

156− Left err -> Trans.liftIO $ throwIO $ PersistError "missing key atom"

157+ Left err -> throwIOPersistError ("missing key atom" ++ show err)

157 Right keyAtom' -> case keyFromValues [atomAsPersistValue keyAtom'] of

158 Right keyAtom' -> case keyFromValues [atomAsPersistValue keyAtom'] of

158− Left err -> throw $ PersistError "key failure"

159+ Left err -> throw $ PersistError ("key failure" `T.append` (T.pack $ show err))

159 Right key -> case body of

160 Right key -> case body of

160− Left err -> Trans.liftIO $ throwIO $ PersistError err

161+ Left err -> throwIOPersistError (show err)

161 Right body' -> return $ Entity key body'

162 Right body' -> return $ Entity key body'

162

163

163commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)

164commonKeyQueryProperties :: (Trans.MonadIO m, PersistEntityBackend val ~ C.Connection, PersistEntity val) => Key val -> ReaderT C.Connection m (RelVarName, RestrictionPredicateExpr)

@@ -202,7 +203,7 @@ updateByKey key updates = do

202 conn <- ask

203 conn <- ask

203 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query

204 maybeErr <- Trans.liftIO $ C.executeDatabaseContextExpr conn query

204 case maybeErr of

205 case maybeErr of

205− Just err -> Trans.liftIO $ throwIO $ PersistError "executeDatabaseExpr error"

206+ Just err -> throwIOPersistError ("executeDatabaseExpr error" ++ show err)

206 Nothing -> return ()

207 Nothing -> return ()

207

208

208--set the truth unconditionally

209--set the truth unconditionally

@@ -331,7 +332,7 @@ instance PersistConfig C.ConnectionInfo where

331 createPoolConfig conf = do

332 createPoolConfig conf = do

332 connErr <- C.connectProjectM36 conf

333 connErr <- C.connectProjectM36 conf

333 case connErr of

334 case connErr of

334− Left err -> throwIO $ PersistError "Failed to create connection"

335+ Left err -> throwIO $ PersistError ("Failed to create connection: " `T.append` (T.pack $ show err))

335 Right conn -> return conn

336 Right conn -> return conn

336 --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a

337 --runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a

337 runPool _ r = runReaderT r

338 runPool _ r = runReaderT r

@@ -407,17 +408,16 @@ instance PersistUnique C.Connection where

407multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr

408multiFilterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Bool -> [Filter val] -> Either RelationalError RestrictionPredicateExpr

408multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate

409multiFilterAsRestrictionPredicate _ [] = Right $ TruePredicate

409multiFilterAsRestrictionPredicate andOr (x:xs) = do

410multiFilterAsRestrictionPredicate andOr (x:xs) = do

410− let pred = if andOr then AndPredicate else OrPredicate

411+ let predicate = if andOr then AndPredicate else OrPredicate

411 filtHead <- filterAsRestrictionPredicate x

412 filtHead <- filterAsRestrictionPredicate x

412 filtTail <- multiFilterAsRestrictionPredicate andOr xs

413 filtTail <- multiFilterAsRestrictionPredicate andOr xs

413− return $ pred filtHead filtTail

414+ return $ predicate filtHead filtTail

414

415

415−filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]

416+filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]

416filterValueToPersistValues v = map toPersistValue $ either return id v

417filterValueToPersistValues v = map toPersistValue $ either return id v

417

418

418filterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Filter val -> Either RelationalError RestrictionPredicateExpr

419filterAsRestrictionPredicate :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => Filter val -> Either RelationalError RestrictionPredicateExpr

419−filterAsRestrictionPredicate filter = let entDef = entityDef $ dummyFromFilter filter in

420+filterAsRestrictionPredicate filterIn = case filterIn of

420− case filter of

421 FilterAnd filters -> multiFilterAsRestrictionPredicate True filters

422 FilterOr filters -> multiFilterAsRestrictionPredicate False filters

423 BackendFilter _ -> error "BackendFilter not supported"

@@ -432,14 +432,13 @@ filterAsRestrictionPredicate filter = let entDef = entityDef $ dummyFromFilter f

432 Nothing -> Left $ AtomTypeNotSupported attrName

433 Just atom' -> Right $ NotPredicate (AttributeEqualityPredicate attrName (NakedAtomExpr atom'))

434 op -> Left $ AtomOperatorNotSupported $ T.pack (show op)

435− Right vals -> Left $ AtomTypeNotSupported attrName

435+ Right _ -> Left $ AtomTypeNotSupported attrName

436

437updateToUpdateTuple :: (PersistEntity val, PersistEntityBackend val ~ C.Connection) => DPT.Update val -> Either RelationalError (AttributeName, Atom)

438updateToUpdateTuple (BackendUpdate _) = error "BackendUpdate not supported"

439−updateToUpdateTuple up@(DPT.Update field value op) = let entDef = entityDef $ dummyFromUpdate up

440− attrName = unDBName $ fieldDB (persistFieldDef field)

439+updateToUpdateTuple (DPT.Update field value op) = let attrName = unDBName $ fieldDB (persistFieldDef field)

441− atom = persistValueAtom $ toPersistValue value

440+ atom = persistValueAtom $ toPersistValue value

442− in case op of

441+ in case op of

443 DPT.Assign -> case atom of

442 DPT.Assign -> case atom of

444 Nothing -> Left $ AtomTypeNotSupported attrName

443 Nothing -> Left $ AtomTypeNotSupported attrName

445 Just atom' -> Right $ (attrName, atom')

444 Just atom' -> Right $ (attrName, atom')

@@ -447,10 +446,9 @@ updateToUpdateTuple up@(DPT.Update field value op) = let entDef = entityDef $ du

447

446

448selectionFromRestriction :: (PersistEntity val, PersistEntityBackend val ~ backend, Trans.MonadIO m, backend ~ C.Connection) => [Filter val] -> ReaderT backend m (Either RelationalError RelationalExpr)

447selectionFromRestriction :: (PersistEntity val, PersistEntityBackend val ~ backend, Trans.MonadIO m, backend ~ C.Connection) => [Filter val] -> ReaderT backend m (Either RelationalError RelationalExpr)

449selectionFromRestriction filters = do

448selectionFromRestriction filters = do

450− conn <- ask

451 runEitherT $ do

449 runEitherT $ do

452 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters

450 restrictionPredicate <- hoistEither $ multiFilterAsRestrictionPredicate True filters

453− let entDef = entityDef $ dummyFromFilters filters

451+ let entDef = entityDef $ dummyFromFilters filters

454 relVarName = unDBName $ entityDB entDef

452 relVarName = unDBName $ entityDB entDef

455 right $ Restrict restrictionPredicate (RelationVariable relVarName)

453 right $ Restrict restrictionPredicate (RelationVariable relVarName)

456

454

@@ -471,7 +469,7 @@ instance PersistQuery C.Connection where

471 Just err -> left err

469 Just err -> left err

472 Nothing -> right ()

470 Nothing -> right ()

473 case e of

471 case e of

474− Left err -> Trans.liftIO $ throwIO $ PersistError "updateWhere pooped"

472+ Left err -> throwIOPersistError ("updateWhere failure: " ++ show err)

475 Right () -> return ()

473 Right () -> return ()

476

474

477 deleteWhere filters = do

475 deleteWhere filters = do

@@ -486,7 +484,7 @@ instance PersistQuery C.Connection where

486 Just err -> left err

484 Just err -> left err

487 Nothing -> right ()

485 Nothing -> right ()

488 case e of

486 case e of

489− Left err -> Trans.liftIO $ throwIO $ PersistError "deleteWhere pooped"

487+ Left err -> throwIOPersistError ("deleteWhere failure: " ++ show err)

490 Right () -> return ()

488 Right () -> return ()

491

489

492 count filters = do

490 count filters = do

@@ -510,7 +508,7 @@ instance PersistQuery C.Connection where

510 Right _ -> Trans.liftIO $ throwIO $ PersistError "count returned wrong data type"

508 Right _ -> Trans.liftIO $ throwIO $ PersistError "count returned wrong data type"

511 Left err -> left err

509 Left err -> left err

512 case e of

510 case e of

513− Left err -> Trans.liftIO $ throwIO $ PersistError "count pooped"

511+ Left err -> throwIOPersistError ("count failure: " ++ show err)

514 Right c -> return c

512 Right c -> return c

515

513

516 --no select options currently supported (sorting, limiting)

514 --no select options currently supported (sorting, limiting)

@@ -535,18 +533,17 @@ instance PersistQuery C.Connection where

535 conn <- ask

533 conn <- ask

536 keys <- runEitherT $ do

534 keys <- runEitherT $ do

537 restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither

535 restrictionExpr <- (lift $ selectionFromRestriction filters) >>= hoistEither

538− let entDef = entityDef $ dummyFromFilters filters

539− keyAttrNames = ["id"] --no support for multi-attribute keys yet

536+ let keyAttrNames = ["id"] --no support for multi-attribute keys yet

540 keyExpr = Project (AttributeNames $ S.fromList keyAttrNames) restrictionExpr

537 keyExpr = Project (AttributeNames $ S.fromList keyAttrNames) restrictionExpr

541 (Relation _ tupleSet) <- (Trans.liftIO $ C.executeRelationalExpr conn keyExpr) >>= hoistEither

538 (Relation _ tupleSet) <- (Trans.liftIO $ C.executeRelationalExpr conn keyExpr) >>= hoistEither

542 let keyMapper :: (PersistEntity record, Trans.MonadIO m) => RelationTuple -> EitherT RelationalError (ReaderT C.Connection m) (Key record)

539 let keyMapper :: (PersistEntity record, Trans.MonadIO m) => RelationTuple -> EitherT RelationalError (ReaderT C.Connection m) (Key record)

543 keyMapper tuple = do

540 keyMapper tuple = do

544 atoms <- hoistEither (atomsForAttributeNames (V.fromList keyAttrNames) tuple)

541 atoms <- hoistEither (atomsForAttributeNames (V.fromList keyAttrNames) tuple)

545 case keyFromValues (map atomAsPersistValue (V.toList atoms)) of

542 case keyFromValues (map atomAsPersistValue (V.toList atoms)) of

546− Left err -> Trans.liftIO $ throwIO $ PersistError "keyFromValues failure"

543+ Left err -> throwIOPersistError ("keyFromValues failure: " ++ show err)

547 Right key -> right key

544 Right key -> right key

548 mapM keyMapper $ asList tupleSet

545 mapM keyMapper $ asList tupleSet

549 case keys of

546 case keys of

550− Left err -> Trans.liftIO $ throwIO $ PersistError "keyFromValues failure2"

547+ Left err -> throwIOPersistError ("keyFromValues failure2: " ++ show err)

551 Right keys' -> return $ return (CL.sourceList keys')

548 Right keys' -> return $ return (CL.sourceList keys')

552

549

test/persistent-driver/test.hs+20−20

@@ -34,7 +34,7 @@ testList :: Test

34testList = TestList $ map mkInProcessTest [testGetBy, testDelete, testUpdate, testCount, testSelect, testSelectKeys]

36main :: IO ()

37−main = do

37+main = do

38 tcounts <- runTestTT testList

39 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

@@ -70,11 +70,11 @@ testGetBy :: ReaderT ProjectM36Backend IO ()

70testGetBy = do

71 let name = "Michael"

72 age = 26

73− m <- insert $ Person name age

73+ _ <- insert $ Person name age

74 michael <- getBy $ UniqueName name

75− michael <- liftIO $ entityFromMaybe michael

75+ michael' <- liftIO $ entityFromMaybe michael

76− liftIO $ assertEqual "name equality" name (personName $ entityVal michael)

76+ liftIO $ assertEqual "name equality" name (personName $ entityVal michael')

77− liftIO $ assertEqual "age equality" age (personAge $ entityVal michael)

77+ liftIO $ assertEqual "age equality" age (personAge $ entityVal michael')

78 return ()

80--insert two people, delete one, check one remains

@@ -84,24 +84,24 @@ testDelete = do

84 age1 = 26

85 name2 = "John"

86 age2 = 30

87− m1 <- insert $ Person name1 age1

87+ _ <- insert $ Person name1 age1

88 m2 <- insert $ Person name2 age2

89 deleteBy $ UniqueName name1 --delete michael

90 nom1 <- getBy $ UniqueName name1

91 --check that m1 was deleted

92 case nom1 of

93− Just m -> liftIO $ assertFailure "deleteBy failure"

93+ Just _ -> liftIO $ assertFailure "deleteBy failure"

94 Nothing -> return ()

95 --check that m2 still exists

96 m2check <- getBy $ UniqueName name2

97 case m2check of

98 Nothing -> liftIO $ assertFailure "deleteBy failure2"

99− Just m -> return ()

99+ Just _ -> return ()

100 --delete m2

101 deleteWhere [PersonName ==. name2]

102 m2del <- get m2

103 case m2del of

104− Just m -> liftIO $ assertFailure "deleteBy failure m2"

104+ Just _ -> liftIO $ assertFailure "deleteBy failure m2"

105 Nothing -> return ()

106 return ()

107

@@ -118,13 +118,13 @@ testUpdate = do

118 update m1 [PersonAge =. 35] -- update m1's age

119 updateWhere [PersonName ==. name2] [PersonName =. name3] --update m2's name

120 m1up <- get m1

121− m1up <- liftIO $ valFromMaybe m1up

121+ m1up' <- liftIO $ valFromMaybe m1up

122 m2up <- get m2

123− m2up <- liftIO $ valFromMaybe m2up

123+ m2up' <- liftIO $ valFromMaybe m2up

124− liftIO $ assertEqual "m1 update" name1 (personName m1up)

124+ liftIO $ assertEqual "m1 update" name1 (personName m1up')

125− liftIO $ assertEqual "m1 update" 35 (personAge m1up)

125+ liftIO $ assertEqual "m1 update" 35 (personAge m1up')

126− liftIO $ assertEqual "m2 update" name3 (personName m2up)

126+ liftIO $ assertEqual "m2 update" name3 (personName m2up')

127− liftIO $ assertEqual "m2 update" age2 (personAge m2up)

127+ liftIO $ assertEqual "m2 update" age2 (personAge m2up')

128 return ()

129

130testCount :: ReaderT ProjectM36Backend IO ()

@@ -133,8 +133,8 @@ testCount = do

133 age1 = 26

134 name2 = "John"

135 age2 = 30

136− m1 <- insert $ Person name1 age1

136+ _ <- insert $ Person name1 age1

137− m2 <- insert $ Person name2 age2

137+ _ <- insert $ Person name2 age2

138 c1 <- count [PersonAge ==. 26]

139 liftIO $ assertEqual "count age" 1 c1

140 c2 <- count [PersonAge !=. 400]

@@ -148,8 +148,8 @@ testSelect = do

148 age1 = 26

149 name2 = "John"

150 age2 = 30

151− m1 <- insert $ Person name1 age1

151+ _ <- insert $ Person name1 age1

152− m2 <- insert $ Person name2 age2

152+ _ <- insert $ Person name2 age2

153 name1List <- selectList [PersonName ==. name1] []

154 liftIO $ assertEqual "select name1 len" 1 (length name1List)

155 liftIO $ assertEqual "select name1 val" name1 ((personName . entityVal . head) name1List)

@@ -162,7 +162,7 @@ testSelectKeys = do

162 age1 = 26

163 name2 = "John"

164 age2 = 30

165− m1 <- insert $ Person name1 age1

165+ _ <- insert $ Person name1 age1

166 m2 <- insert $ Person name2 age2

167 keysList <- selectKeysList [PersonAge ==. age2] []

168 liftIO $ assertEqual "select keysList len" 1 (length keysList)