persistent 2.14.0.1 → 2.14.0.2
raw patch · 5 files changed
+37/−20 lines, 5 files
Files
- ChangeLog.md +5/−0
- Database/Persist/TH.hs +27/−17
- persistent.cabal +1/−1
- test/Database/Persist/TH/NoFieldSelectorsSpec.hs +2/−2
- test/Database/Persist/TH/OverloadedLabelSpec.hs +2/−0
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for persistent +## 2.14.0.2++* [#1407](https://github.com/yesodweb/persistent/pull/1407)+ * Fix a name shadowing warning.+ ## 2.14.0.1 * [#1392](https://github.com/yesodweb/persistent/pull/1392)
Database/Persist/TH.hs view
@@ -119,8 +119,8 @@ import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..)) -import Database.Persist.Class.PersistEntity import Database.Persist+import Database.Persist.Class.PersistEntity import Database.Persist.Quasi import Database.Persist.Quasi.Internal import Database.Persist.Sql@@ -1462,9 +1462,15 @@ -> Exp -- ^ record value -> Name -- ^ field name to update -> Exp -- ^ new value- -> Exp-fieldUpd con names record name new = CaseE record- [ Match (RecP con pats) (NormalB body) []]+ -> Q Exp+fieldUpd con names record name new = do+ pats <-+ fmap mconcat $ forM names $ \k -> do+ varName <- VarP <$> newName (nameBase k)+ pure [(k, varName) | k /= name]++ pure $ CaseE record+ [ Match (RecP con pats) (NormalB body) []] where body = RecConE con [ if k == name then (name, new) else (k, VarE k)@@ -1486,23 +1492,26 @@ let idClause = normalClause [conp (keyIdName entDef) []] (lens' `AppE` getId `AppE` setId)- return $ idClause : if unboundEntitySum entDef- then fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)- else zipWith (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames+ (idClause :) <$> if unboundEntitySum entDef+ then pure $ fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)+ else zipWithM (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames where fieldNames = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef- toClause lens' getVal dot keyVar valName xName fieldDef fieldName = normalClause- [conp (filterConName mps entDef fieldDef) []]- (lens' `AppE` getter `AppE` setter)+ toClause lens' getVal dot keyVar valName xName fieldDef fieldName = do+ setter <- mkSetter+ pure $ normalClause+ [conp (filterConName mps entDef fieldDef) []]+ (lens' `AppE` getter `AppE` setter) where defName = mkEntityDefName entDef getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal)- setter = LamE- [ conp 'Entity [VarP keyVar, VarP valName]- , VarP xName- ]- $ ConE 'Entity `AppE` VarE keyVar- `AppE` fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName)+ mkSetter = do+ updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName)+ pure $ LamE+ [ conp 'Entity [VarP keyVar, VarP valName]+ , VarP xName+ ]+ $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr toSumClause lens' keyVar valName xName fieldDef = normalClause [conp (filterConName mps entDef fieldDef) []]@@ -2167,6 +2176,7 @@ t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 vars = mkForallTV fT : (if mpsGeneric mps then [mkForallTV backend1{-, PlainTV backend2-}] else [])+ fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y return [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $ (aT `arrow` (VarT fT `AppT` bT)) `arrow`@@ -2179,7 +2189,7 @@ [ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)] , FunD setterN $ return $ normalClause [VarP yN]- (fieldUpd (mkEntityDefName ent) fieldNames a fieldName y)+ fieldUpdClause ] ] where
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.14.0.1+version: 2.14.0.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/Database/Persist/TH/NoFieldSelectorsSpec.hs view
@@ -32,9 +32,9 @@ #else -spec :: Spec +spec :: Spec spec = do it "only works with GHC 9.2 or greater" $ do- pendingWith "only works with GHC 9.2 or greater" + pendingWith "only works with GHC 9.2 or greater" #endif
test/Database/Persist/TH/OverloadedLabelSpec.hs view
@@ -13,6 +13,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-}+ module Database.Persist.TH.OverloadedLabelSpec where import TemplateTestImports