persistent 2.13.3.3 → 2.13.3.4
raw patch · 9 files changed
+222/−21 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +9/−0
- Database/Persist/TH.hs +39/−18
- persistent.cabal +5/−1
- test/Database/Persist/QuasiSpec.hs +10/−0
- test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs +44/−0
- test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs +21/−0
- test/Database/Persist/TH/NoFieldSelectorsSpec.hs +40/−0
- test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs +47/−0
- test/Database/Persist/THSpec.hs +7/−2
ChangeLog.md view
@@ -1,5 +1,14 @@ # Changelog for persistent +# 2.13.3.4++* [#1379](https://github.com/yesodweb/persistent/pull/1379)+ * `mkPersist` now generates code that compiles under `NoFieldSelectors` and `DuplicateRecordFields` even if field labels are not prefixed+* [#1376](https://github.com/yesodweb/persistent/pull/1376)+ * Add coverage for parsing nested parens/lists in field types+* [#1370](https://github.com/yesodweb/persistent/pull/1370)+ * Add spec to assert Persistent.TH is the only import required when defining entities+ ## 2.13.3.3 * [#1369](https://github.com/yesodweb/persistent/pull/1369)
Database/Persist/TH.hs view
@@ -78,10 +78,10 @@ , Value(Object) , eitherDecodeStrict' , object+ , withObject , (.:) , (.:?) , (.=)- , withObject ) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as Key@@ -1404,8 +1404,30 @@ unboundEntitySum :: UnboundEntityDef -> Bool unboundEntitySum = entitySum . unboundEntityDef -mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Q [Clause]-mkLensClauses mps entDef = do+fieldSel :: Name -> Name -> Exp+fieldSel conName fieldName+ = LamE [RecP conName [(fieldName, VarP xName)]] (VarE xName)+ where+ xName = mkName "x"++fieldUpd :: Name -- ^ constructor name+ -> [Name] -- ^ list of field names+ -> 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) []]+ where+ body = RecConE con+ [ if k == name then (name, new) else (k, VarE k)+ | k <- names+ ]+ pats = [ (k, VarP k) | k <- names, k /= name]+++mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause]+mkLensClauses mps entDef genDataType = do lens' <- [|lensPTH|] getId <- [|entityKey|] setId <- [|\(Entity _ value) key -> Entity key value|]@@ -1419,21 +1441,21 @@ (lens' `AppE` getId `AppE` setId) return $ idClause : if unboundEntitySum entDef then fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef)- else fmap (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef)+ else zipWith (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames where- toClause lens' getVal dot keyVar valName xName fieldDef = normalClause+ 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) where- fieldName = fieldDefToRecordName mps entDef fieldDef- getter = InfixE (Just $ VarE fieldName) dot (Just getVal)+ 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` RecUpdE- (VarE valName)- [(fieldName, VarE xName)]+ $ ConE 'Entity `AppE` VarE keyVar+ `AppE` fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName) toSumClause lens' keyVar valName xName fieldDef = normalClause [conp (filterConName mps entDef fieldDef) []]@@ -1766,7 +1788,7 @@ genericDataType mps entName $ mpsBackend mps | otherwise = id - lensClauses <- mkLensClauses mps entDef+ lensClauses <- mkLensClauses mps entDef genDataType lenses <- mkLenses mps entityMap entDef let instanceConstraint = if not (mpsGeneric mps) then [] else@@ -2015,9 +2037,8 @@ mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] mkLenses mps _ _ | not (mpsGenerateLenses mps) = return [] mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return []-mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent) $ \field -> do+mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` fieldNames) $ \(field, fieldName) -> do let lensName = mkEntityLensName mps ent field- fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter" fN <- newName "f"@@ -2054,14 +2075,14 @@ (NormalB $ fmapE `AppE` setter `AppE` (f `AppE` needle))- [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)]+ [ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)] , FunD setterN $ return $ normalClause [VarP yN]- (RecUpdE a- [ (fieldName, y)- ])+ (fieldUpd (mkEntityDefName ent) fieldNames a fieldName y) ] ]+ where+ fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent #if MIN_VERSION_template_haskell(2,17,0) mkPlainTV@@ -2993,7 +3014,7 @@ unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef unKeyExp :: UnboundEntityDef -> Exp-unKeyExp = VarE . unKeyName+unKeyExp ent = fieldSel (keyConName ent) (unKeyName ent) backendT :: Type backendT = VarT backendName
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.13.3.3+version: 2.13.3.4 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -181,7 +181,11 @@ Database.Persist.TH.MaybeFieldDefsSpec Database.Persist.TH.MultiBlockSpec Database.Persist.TH.MultiBlockSpec.Model+ Database.Persist.TH.NestedSymbolsInTypeSpec+ Database.Persist.TH.NestedSymbolsInTypeSpecImports+ Database.Persist.TH.NoFieldSelectorsSpec Database.Persist.TH.OverloadedLabelSpec+ Database.Persist.TH.RequireOnlyPersistImportSpec Database.Persist.TH.SharedPrimaryKeyImportedSpec Database.Persist.TH.SharedPrimaryKeySpec Database.Persist.THSpec
test/Database/Persist/QuasiSpec.hs view
@@ -510,6 +510,16 @@ baz = FTTypeCon Nothing "Baz" parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( foo `FTApp` bars `FTApp` baz)+ it "nested list / parens (list inside parens)" $ do+ let maybeCon = FTTypeCon Nothing "Maybe"+ int = FTTypeCon Nothing "Int"+ parseFieldType "Maybe (Maybe [Int])" `shouldBe` Right+ (maybeCon `FTApp` (maybeCon `FTApp` FTList int))+ it "nested list / parens (parens inside list)" $ do+ let maybeCon = FTTypeCon Nothing "Maybe"+ int = FTTypeCon Nothing "Int"+ parseFieldType "[Maybe (Maybe Int)]" `shouldBe` Right+ (FTList (maybeCon `FTApp` (maybeCon `FTApp` int))) it "fails on lowercase starts" $ do parseFieldType "nothanks" `shouldBe` Left "PSFail ('n',\"othanks\")"
+ test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -Wno-unused-local-binds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Persist.TH.NestedSymbolsInTypeSpec where++import Data.Map+import Database.Persist.TH.NestedSymbolsInTypeSpecImports+import TemplateTestImports++mkPersist sqlSettings [persistLowerCase|+PathEntitySimple+ readOnly (Maybe (SomePath ReadOnly))++PathEntityNested+ paths (Maybe (Map Text [SomePath ReadWrite]))+|]++spec :: Spec+spec = describe "NestedSymbolsInType" $ do+ it "should support nested parens" $ do+ let mkPathEntitySimple :: Maybe (SomePath ReadOnly) -> PathEntitySimple+ mkPathEntitySimple = PathEntitySimple+ pathEntitySimpleReadOnly' :: PathEntitySimple -> Maybe (SomePath ReadOnly)+ pathEntitySimpleReadOnly' = pathEntitySimpleReadOnly+ compiles++ it "should support deeply nested parens + square brackets" $ do+ let mkPathEntityNested :: Maybe (Map Text [SomePath ReadWrite]) -> PathEntityNested+ mkPathEntityNested = PathEntityNested+ pathEntityNestedPaths' :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite])+ pathEntityNestedPaths' = pathEntityNestedPaths+ compiles++compiles :: Expectation+compiles = True `shouldBe` True
+ test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}++module Database.Persist.TH.NestedSymbolsInTypeSpecImports where++import Data.Proxy+import TemplateTestImports++data ReadOnly+data ReadWrite++newtype SomePath a = SomePath Text++instance PersistFieldSql (SomePath a) where+ sqlType _ = SqlString++instance PersistField (SomePath a) where+ toPersistValue (SomePath n) =+ toPersistValue n+ fromPersistValue v =+ SomePath <$> fromPersistValue v
+ test/Database/Persist/TH/NoFieldSelectorsSpec.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 902+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE DuplicateRecordFields #-}+#endif+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Persist.TH.NoFieldSelectorsSpec where++import TemplateTestImports++#if __GLASGOW_HASKELL__ >= 902++mkPersist sqlSettings {mpsFieldLabelModifier = const id} [persistLowerCase|+User+ name Text++Team+ name Text+|]++spec :: Spec+spec = it "compiles" True++#else++spec :: Spec +spec = do+ it "only works with GHC 9.2 or greater" $ do+ pendingWith "only works with GHC 9.2 or greater" ++#endif
+ test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Persist.TH.RequireOnlyPersistImportSpec where++-- This test asserts this is the only import required to define entities+-- See: https://github.com/yesodweb/persistent/pull/1369+import Database.Persist.TH++-- always explicitly import qualified Hspec in the context of this spec+import qualified Test.Hspec as HS++mkPersist sqlSettings [persistLowerCase|+Plain+ name String+ age Int+ deriving Show Eq++JsonEncoded json+ name String+ age Int+ deriving Show Eq+|]++spec :: HS.Spec+spec =+ HS.describe "RequireOnlyPersistImport" $ do+ HS.it "Plain" $ do+ let typeSigPlain :: String -> Int -> Plain+ typeSigPlain = Plain+ compiles++ HS.it "JsonEncoded" $ do+ let typeSigJsonEncoded :: String -> Int -> JsonEncoded+ typeSigJsonEncoded = JsonEncoded+ compiles++compiles :: HS.Expectation+compiles = True `HS.shouldBe` True
test/Database/Persist/THSpec.hs view
@@ -46,21 +46,24 @@ import TemplateTestImports -import qualified Database.Persist.TH.PersistWithSpec as PersistWithSpec+import qualified Database.Persist.TH.CommentSpec as CommentSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec+import qualified Database.Persist.TH.NestedSymbolsInTypeSpec as NestedSymbolsInTypeSpec import qualified Database.Persist.TH.MaybeFieldDefsSpec as MaybeFieldDefsSpec import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec+import qualified Database.Persist.TH.NoFieldSelectorsSpec as NoFieldSelectorsSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec+import qualified Database.Persist.TH.PersistWithSpec as PersistWithSpec+import qualified Database.Persist.TH.RequireOnlyPersistImportSpec as RequireOnlyPersistImportSpec import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec-import qualified Database.Persist.TH.CommentSpec as CommentSpec -- test to ensure we can have types ending in Id that don't trash the TH -- machinery@@ -173,12 +176,14 @@ spec = describe "THSpec" $ do PersistWithSpec.spec KindEntitiesSpec.spec+ NestedSymbolsInTypeSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec ImplicitIdColSpec.spec MaybeFieldDefsSpec.spec MigrationOnlySpec.spec+ NoFieldSelectorsSpec.spec EmbedSpec.spec DiscoverEntitiesSpec.spec MultiBlockSpec.spec