From 1a83621b44b7f34bdf839a02ec07173b2b200c22 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 20 Apr 2021 14:14:57 +0100 Subject: [PATCH 1/3] Refactoring name generating functions in TH (#1218) * Extract name function for ToJSON instance * Extract mkRecName * Extract `mkEntityDefDeriveNames` * Extract mkEntityDefName* functions * Move sumConstrName * Extract mkConstraintName * Extract `mkEntityNameHS*` functions * Refactor using new functions * Absorb more functions * Another extraction * Move already extracted functions for key names * Refactor to reuse functions * More reuse * More reuse * Move filterConName * Consistent unpack * Dont shaddow name * Extracting helpers * Change mkRecName to take EntityDef * Move entity derives logic out into name creation function * DRY up `backendT` * Rename function * Refactor cols value * More renaming * More shifting around * Update changelog * Flip changelog formatting * Tweaking changlog format again --- persistent/ChangeLog.md | 4 +- persistent/Database/Persist/TH.hs | 323 +++++++++++++++++------------- 2 files changed, 189 insertions(+), 138 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 4d1b76097..71405bbeb 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,7 +2,9 @@ ## 2.12.1.0 -* [#1226](https://github.com/yesodweb/persistent/pull/1226) +* [#1218](https://github.com/yesodweb/persistent/pull/1218) + * Refactoring name generating functions in TH +* [#1226](https://github.com/yesodweb/persistent/pull/1226) * Expose the `filterClause` and `filterClauseWithValues` functions to support the `upsertWhere` functionality in `persistent-postgresql`. diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 9968527ae..7224f95db 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -93,7 +93,7 @@ import GHC.TypeLits import Instances.TH.Lift () -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` -import Language.Haskell.TH.Lib (appT, varT, conT, varE, varP, conE, litT, strTyLit) +import Language.Haskell.TH.Lib (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.PathPieces (PathPiece(..)) @@ -104,16 +104,6 @@ import Database.Persist import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.Quasi --- | This special-cases "type_" and strips out its underscore. When --- used for JSON serialization and deserialization, it works around --- -unFieldNameHSForJSON :: FieldNameHS -> Text -unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS - where - fixTypeUnderscore = \case - "type" -> "type_" - name -> name - -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). persistWith :: PersistSettings -> QuasiQuoter @@ -256,7 +246,6 @@ foreignReference field = case fieldReference field of ForeignRef ref _ -> Just ref _ -> Nothing - -- fieldSqlType at parse time can be an Exp -- This helps delay setting fieldSqlType until lift time data EntityDefSqlTypeExp @@ -584,9 +573,7 @@ upperFirst t = dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec dataTypeDec mps entDef = do - let entityInstances = map (mkName . unpack) $ entityDerives entDef - additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps - names = entityInstances <> additionalInstances + let names = mkEntityDefDeriveNames mps entDef let (stocks, anyclasses) = partitionEithers (map stratFor names) let stockDerives = do @@ -614,37 +601,27 @@ dataTypeDec mps entDef = do ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable ] ) - mkCol x fd@FieldDef {..} = - (mkName $ unpack $ recNameF mps x fieldHaskell, - if fieldStrict then isStrict else notStrict, - maybeIdType mps fd Nothing Nothing - ) + (nameFinal, paramsFinal) - | mpsGeneric mps = (nameG, [PlainTV backend]) - | otherwise = (name, []) - nameG = mkName $ unpack $ unEntityNameHS (entityHaskell entDef) ++ "Generic" - name = mkName $ unpack $ unEntityNameHS $ entityHaskell entDef - cols = map (mkCol $ entityHaskell entDef) $ entityFields entDef - backend = backendName + | mpsGeneric mps = (mkEntityDefGenericName entDef, [PlainTV backendName]) + | otherwise = (mkEntityDefName entDef, []) + + cols :: [VarBangType] + cols = do + fieldDef <- entityFields entDef + let recordName = fieldDefToRecordName mps entDef fieldDef + strictness = if fieldStrict fieldDef then isStrict else notStrict + fieldIdType = maybeIdType mps fieldDef Nothing Nothing + in pure (recordName, strictness, fieldIdType) constrs | entitySum entDef = map sumCon $ entityFields entDef - | otherwise = [RecC name cols] + | otherwise = [RecC (mkEntityDefName entDef) cols] sumCon fieldDef = NormalC (sumConstrName mps entDef fieldDef) [(notStrict, maybeIdType mps fieldDef Nothing Nothing)] -sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -sumConstrName mps entDef FieldDef {..} = mkName $ unpack name - where - name - | mpsPrefixFields mps = modifiedName ++ "Sum" - | otherwise = fieldName ++ "Sum" - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unEntityNameHS $ entityHaskell entDef - fieldName = upperFirst $ unFieldNameHS fieldHaskell - uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec uniqueTypeDec mps entDef = #if MIN_VERSION_template_haskell(2,15,0) @@ -662,8 +639,8 @@ uniqueTypeDec mps entDef = #endif mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con -mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) = - NormalC (mkName $ unpack constr) types +mkUnique mps entDef (UniqueDef constr _ fields attrs) = + NormalC (mkConstraintName constr) types where types = map (go . flip lookup3 (entityFields entDef) . unFieldNameHS . fst) fields @@ -676,7 +653,7 @@ mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) = lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) lookup3 s [] = - error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr + error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr lookup3 x (fd@FieldDef {..}:rest) | x == unFieldNameHS fieldHaskell = (fd, nullable fieldAttrs) | otherwise = lookup3 x rest @@ -708,13 +685,14 @@ backendDataType mps | mpsGeneric mps = backendT | otherwise = mpsBackend mps -genericDataType :: MkPersistSettings - -> EntityNameHS - -> Type -- ^ backend - -> Type -genericDataType mps (EntityNameHS typ') backend - | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend - | otherwise = ConT $ mkName $ unpack typ' +genericDataType + :: MkPersistSettings + -> EntityNameHS + -> Type -- ^ backend + -> Type +genericDataType mps name backend + | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend + | otherwise = ConT $ mkEntityNameHSName name idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type idType mps fieldDef mbackend = @@ -731,8 +709,8 @@ degen [] = in [normalClause [WildP] err] degen x = x -mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec -mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do +mkToPersistFields :: MkPersistSettings -> EntityDef -> Q Dec +mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } = do clauses <- if isSum then sequence $ zipWith goSum fields [1..] @@ -742,7 +720,8 @@ mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fi go :: Q Clause go = do xs <- sequence $ replicate fieldCount $ newName "x" - let pat = ConP (mkName constr) $ map VarP xs + let name = mkEntityDefName ed + pat = ConP name $ map VarP xs sp <- [|SomePersistField|] let bod = ListE $ map (AppE sp . VarE) xs return $ normalClause [pat] bod @@ -776,7 +755,7 @@ mkToFieldNames pairs = do names' <- lift names return $ normalClause - [RecP (mkName $ unpack $ unConstraintNameHS constr) []] + [RecP (mkConstraintName constr) []] names' mkUniqueToValues :: [UniqueDef] -> Q Dec @@ -787,7 +766,7 @@ mkUniqueToValues pairs = do go :: UniqueDef -> Q Clause go (UniqueDef constr _ names _) = do xs <- mapM (const $ newName "x") names - let pat = ConP (mkName $ unpack $ unConstraintNameHS constr) $ map VarP xs + let pat = ConP (mkConstraintName constr) $ map VarP xs tpv <- [|toPersistValue|] let bod = ListE $ map (AppE tpv . VarE) xs return $ normalClause [pat] bod @@ -804,8 +783,7 @@ mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause] mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) = fromValues entDef "fromPersistValues" entE $ entityFields entDef where - entE = ConE $ mkName $ unpack entName - entName = unEntityNameHS $ entityHaskell entDef + entE = entityDefConE entDef mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] @@ -854,11 +832,11 @@ mkLensClauses mps entDef = do then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields entDef) else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields entDef) where - toClause lens' getVal dot keyVar valName xName f = normalClause - [ConP (filterConName mps entDef f) []] + toClause lens' getVal dot keyVar valName xName fieldDef = normalClause + [ConP (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where - fieldName = mkName $ unpack $ recNameF mps (entityHaskell entDef) (fieldHaskell f) + fieldName = fieldDefToRecordName mps entDef fieldDef getter = InfixE (Just $ VarE fieldName) dot (Just getVal) setter = LamE [ ConP 'Entity [VarP keyVar, VarP valName] @@ -989,39 +967,6 @@ mkKeyTypeDec mps entDef = do supplement :: [Name] -> [Name] supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) -keyIdName :: EntityDef -> Name -keyIdName = mkName . unpack . keyIdText - -keyIdText :: EntityDef -> Text -keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id" - -unKeyName :: EntityDef -> Name -unKeyName entDef = mkName $ "un" `mappend` keyString entDef - -unKeyExp :: EntityDef -> Exp -unKeyExp = VarE . unKeyName - -backendT :: Type -backendT = VarT backendName - -backendName :: Name -backendName = mkName "backend" - -keyConName :: EntityDef -> Name -keyConName entDef = mkName $ resolveConflict $ keyString entDef - where - resolveConflict kn = if conflict then kn `mappend` "'" else kn - conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef - -keyConExp :: EntityDef -> Exp -keyConExp = ConE . keyConName - -keyString :: EntityDef -> String -keyString = unpack . keyText - -keyText :: EntityDef -> Text -keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key" - -- | Returns 'True' if the key definition has more than 1 field. -- -- @since 2.11.0.0 @@ -1047,11 +992,6 @@ keyFields mps entDef = case entityPrimary entDef of , ftToType $ fieldType fieldDef ) -keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -keyFieldName mps entDef fieldDef - | pkNewtype mps entDef = unKeyName entDef - | otherwise = mkName $ unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef) - mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec mkKeyToValues mps entDef = do (p, e) <- case entityPrimary entDef of @@ -1141,10 +1081,9 @@ mkEntity entityMap mps entDef = do if mpsGeneric mps then liftAndFixKeys entityMap entDef else makePersistEntityDefExp mps entityMap entDef - let nameT = unEntityNameHS entName - let nameS = unpack nameT + let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType - tpf <- mkToPersistFields mps nameS entDef + tpf <- mkToPersistFields mps entDef fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef @@ -1160,7 +1099,7 @@ mkEntity entityMap mps entDef = do let addSyn -- FIXME maybe remove this | mpsGeneric mps = (:) $ - TySynD (mkName nameS) [] $ + TySynD name [] $ genericDataType mps entName $ mpsBackend mps | otherwise = id @@ -1175,9 +1114,7 @@ mkEntity entityMap mps entDef = do Just prim -> do recordName <- newName "record" let keyCon = keyConName entDef - keyFields' = - map (mkName . T.unpack . recNameF mps entName . fieldHaskell) - (compositeFields prim) + keyFields' = fieldDefToRecordName mps entDef <$> compositeFields prim constr = foldl' AppE @@ -1198,7 +1135,7 @@ mkEntity entityMap mps entDef = do return $ addSyn $ dtd : mconcat fkc `mappend` ([ TySynD (keyIdName entDef) [] $ - ConT ''Key `AppT` ConT (mkName nameS) + ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entDef , keyTypeDec @@ -1268,7 +1205,7 @@ mkUniqueKeyInstances mps entDef = do withPersistStoreWriteCxt = if mpsGeneric mps then do - write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |] + write <- [t|PersistStoreWrite $(pure backendT) |] pure [write] else do pure [] @@ -1330,9 +1267,8 @@ mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec] mkLenses mps _ | not (mpsGenerateLenses mps) = return [] mkLenses _ ent | entitySum ent = return [] mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do - let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) - lensName = mkName $ unpack lensName' - fieldName = mkName $ unpack $ "_" ++ lensName' + let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) + fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter" fN <- newName "f" @@ -1378,11 +1314,11 @@ mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] mkForeignKeysComposite mps entDef ForeignDef {..} = if not foreignToPrimary then return [] else do - let fieldName f = mkName $ unpack $ recNameF mps (entityHaskell entDef) f + let fieldName = fieldNameToRecordName mps entDef let fname = fieldName (constraintToField foreignConstraintNameHaskell) let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell let reftableKeyName = mkName $ reftableString `mappend` "Key" - let tablename = mkName $ unpack $ entityText entDef + let tablename = mkEntityDefName entDef recordName <- newName "record" let mkFldE ((foreignName, _),ff) = case ff of @@ -1566,8 +1502,8 @@ mkEntityDefList entityList entityDefs = do let entityListName = mkName entityList edefs <- fmap ListE . forM entityDefs - $ \(EntityDef { entityHaskell = EntityNameHS haskellName }) -> - let entityType = conT (mkName (T.unpack haskellName)) + $ \entDef -> + let entityType = entityDefConT entDef in [|entityDef (Proxy :: Proxy $(entityType))|] typ <- [t|[EntityDef]|] pure @@ -1589,13 +1525,13 @@ mkUniqueKeys def = do return (x, x') let pcs = map (go xs) $ entityUniques def let pat = ConP - (mkName $ unpack $ unEntityNameHS $ entityHaskell def) + (mkEntityDefName def) (map (VarP . snd) xs) return $ normalClause [pat] (ListE pcs) go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp go xs (UniqueDef name _ cols _) = - foldl' (go' xs) (ConE (mkName $ unpack $ unConstraintNameHS name)) (map fst cols) + foldl' (go' xs) (ConE (mkConstraintName name)) (map fst cols) go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp go' xs front col = @@ -1799,26 +1735,6 @@ mkField mps et cd = do maybeNullable :: FieldDef -> Bool maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr -filterConName :: MkPersistSettings - -> EntityDef - -> FieldDef - -> Name -filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) - -filterConName' :: MkPersistSettings - -> EntityNameHS - -> FieldNameHS - -> Name -filterConName' mps entity field = mkName $ unpack name - where - name - | field == FieldNameHS "Id" = entityName ++ fieldName - | mpsPrefixFields mps = modifiedName - | otherwise = fieldName - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unEntityNameHS entity - fieldName = upperFirst $ unFieldNameHS field - ftToType :: FieldType -> Type ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t -- This type is generated from the Quasi-Quoter. @@ -1846,8 +1762,7 @@ mkJSON mps def = do obj <- newName "obj" mzeroE <- [|mzero|] - xs <- mapM (newName . unpack . unFieldNameHSForJSON . fieldHaskell) - $ entityFields def + xs <- mapM fieldToJSONValName (entityFields def) let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def typ = genericDataType mps (entityHaskell def) backendT @@ -1960,13 +1875,13 @@ mkSymbolToFieldInstances mps ed = do litT $ strTyLit $ T.unpack $ unFieldNameHS $ fieldHaskell fieldDef :: Q Type - nameG = mkName $ unpack $ unEntityNameHS (entityHaskell ed) ++ "Generic" + nameG = mkEntityDefGenericName ed recordNameT | mpsGeneric mps = conT nameG `appT` varT backendName | otherwise = - conT $ mkName $ T.unpack $ unEntityNameHS $ entityHaskell ed + entityDefConT ed fieldTypeT = maybeIdType mps fieldDef Nothing Nothing @@ -2012,3 +1927,137 @@ requireExtensions requiredExtensions = do where extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" + +-- | creates a TH Name for use in the ToJSON instance +fieldToJSONValName :: FieldDef -> Q Name +fieldToJSONValName = + newName . T.unpack . unFieldNameHSForJSON . fieldHaskell + +-- | This special-cases "type_" and strips out its underscore. When +-- used for JSON serialization and deserialization, it works around +-- +unFieldNameHSForJSON :: FieldNameHS -> Text +unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS + where + fixTypeUnderscore = \case + "type" -> "type_" + name -> name + +entityDefConK :: EntityDef -> Kind +entityDefConK = conK . mkEntityDefName + +entityDefConT :: EntityDef -> Q Type +entityDefConT = pure . entityDefConK + +entityDefConE :: EntityDef -> Exp +entityDefConE = ConE . mkEntityDefName + +-- | creates a TH Name for an entity's field, based on the entity +-- name and the field name, so for example: +-- +-- Customer +-- name Text +-- +-- This would generate `customerName` as a TH Name +fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name +fieldNameToRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName + +-- | as above, only takes a `FieldDef` +fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef) + +-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` +mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name] +mkEntityDefDeriveNames mps entDef = + let entityInstances = mkName . T.unpack <$> entityDerives entDef + additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps + in entityInstances <> additionalInstances + +-- | Make a TH Name for the EntityDef's Haskell type +mkEntityNameHSName :: EntityNameHS -> Name +mkEntityNameHSName = + mkName . T.unpack . unEntityNameHS + +-- | As above only taking an `EntityDef` +mkEntityDefName :: EntityDef -> Name +mkEntityDefName = + mkEntityNameHSName . entityHaskell + +-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric +mkEntityDefGenericName :: EntityDef -> Name +mkEntityDefGenericName = + mkEntityNameHSGenericName . entityHaskell + +mkEntityNameHSGenericName :: EntityNameHS -> Name +mkEntityNameHSGenericName name = + mkName $ T.unpack (unEntityNameHS name <> "Generic") + +sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name + where + name + | mpsPrefixFields mps = modifiedName ++ "Sum" + | otherwise = fieldName ++ "Sum" + modifiedName = mpsConstraintLabelModifier mps entityName fieldName + entityName = unEntityNameHS $ entityHaskell entDef + fieldName = upperFirst $ unFieldNameHS fieldHaskell + +-- | Turn a ConstraintName into a TH Name +mkConstraintName :: ConstraintNameHS -> Name +mkConstraintName (ConstraintNameHS name) = + mkName (T.unpack name) + +keyIdName :: EntityDef -> Name +keyIdName = mkName . T.unpack . keyIdText + +keyIdText :: EntityDef -> Text +keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id" + +unKeyName :: EntityDef -> Name +unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef + +unKeyExp :: EntityDef -> Exp +unKeyExp = VarE . unKeyName + +backendT :: Type +backendT = VarT backendName + +backendName :: Name +backendName = mkName "backend" + +keyConName :: EntityDef -> Name +keyConName entDef = mkName $ T.unpack $ resolveConflict $ keyText entDef + where + resolveConflict kn = if conflict then kn `mappend` "'" else kn + conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef + +keyConExp :: EntityDef -> Exp +keyConExp = ConE . keyConName + +keyText :: EntityDef -> Text +keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key" + +keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +keyFieldName mps entDef fieldDef + | pkNewtype mps entDef = unKeyName entDef + | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef) + +filterConName :: MkPersistSettings + -> EntityDef + -> FieldDef + -> Name +filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) + +filterConName' :: MkPersistSettings + -> EntityNameHS + -> FieldNameHS + -> Name +filterConName' mps entity field = mkName $ T.unpack name + where + name + | field == FieldNameHS "Id" = entityName ++ fieldName + | mpsPrefixFields mps = modifiedName + | otherwise = fieldName + modifiedName = mpsConstraintLabelModifier mps entityName fieldName + entityName = unEntityNameHS entity + fieldName = upperFirst $ unFieldNameHS field From 69fa44a0ee8bb46b66999e166687d42711d591a0 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Tue, 20 Apr 2021 06:16:05 -0700 Subject: [PATCH 2/3] Fixing Haddock formatting for a new method (#1228) * this should fix the haddock formatting * updated styling --- .../Database/Persist/Postgresql.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 73c967fb9..970e9772f 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1865,7 +1865,7 @@ excludeNotEqualToOriginal field = -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. -- --- -- @since 2.12.1.0 +-- @since 2.12.1.0 upsertManyWhere :: forall record backend m. ( backend ~ PersistEntityBackend record, @@ -1874,14 +1874,10 @@ upsertManyWhere :: PersistEntity record, MonadIO m ) => - -- | A list of the records you want to insert, or update - [record] -> - -- | A list of the fields you want to copy over. - [HandleUpdateCollision record] -> - -- | A list of the updates to apply that aren't dependent on the record being inserted. - [Update record] -> - -- | A filter condition that dictates the scope of the updates - [Filter record] -> + [record] -> -- ^ A list of the records you want to insert, or update + [HandleUpdateCollision record] -> -- ^ A list of the fields you want to copy over. + [Update record] -> -- ^ A list of the updates to apply that aren't dependent on the record being inserted. + [Filter record] -> -- ^ A filter condition that dictates the scope of the updates ReaderT backend m () upsertManyWhere [] _ _ _ = return () upsertManyWhere records fieldValues updates filters = do From 53359c834f649442c2f17379e24d78fb6e8719d4 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Tue, 20 Apr 2021 07:18:07 -0600 Subject: [PATCH 3/3] Generate #id labels (#1229) * Generate #id labels * changelog * format --- persistent/ChangeLog.md | 5 ++ .../Database/Persist/Class/PersistUnique.hs | 59 ++++++++++--------- persistent/Database/Persist/TH.hs | 13 ++-- persistent/persistent.cabal | 2 +- .../Persist/TH/OverloadedLabelSpec.hs | 6 ++ 5 files changed, 52 insertions(+), 33 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 71405bbeb..88440241c 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.12.1.1 + +* [#1229](https://github.com/yesodweb/persistent/pull/1229) + * The `#id` labels are now generated for entities. + ## 2.12.1.0 * [#1218](https://github.com/yesodweb/persistent/pull/1218) diff --git a/persistent/Database/Persist/Class/PersistUnique.hs b/persistent/Database/Persist/Class/PersistUnique.hs index f8f8f87b4..fcb0fd1ed 100644 --- a/persistent/Database/Persist/Class/PersistUnique.hs +++ b/persistent/Database/Persist/Class/PersistUnique.hs @@ -3,42 +3,42 @@ {-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique - ( PersistUniqueRead(..) - , PersistUniqueWrite(..) - , OnlyOneUniqueKey(..) - , onlyOneUniqueDef - , AtLeastOneUniqueKey(..) - , atLeastOneUniqueDef - , NoUniqueKeysError - , MultipleUniqueKeysError - , getByValue - , getByValueUniques - , insertBy - , insertUniqueEntity - , replaceUnique - , checkUnique - , checkUniqueUpdateable - , onlyUnique - , defaultUpsertBy - , defaultPutMany - , persistUniqueKeyValues - ) - where + ( PersistUniqueRead(..) + , PersistUniqueWrite(..) + , OnlyOneUniqueKey(..) + , onlyOneUniqueDef + , AtLeastOneUniqueKey(..) + , atLeastOneUniqueDef + , NoUniqueKeysError + , MultipleUniqueKeysError + , getByValue + , getByValueUniques + , insertBy + , insertUniqueEntity + , replaceUnique + , checkUnique + , checkUniqueUpdateable + , onlyUnique + , defaultUpsertBy + , defaultPutMany + , persistUniqueKeyValues + ) + where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Function (on) -import Data.List ((\\), deleteFirstsBy) +import Data.List (deleteFirstsBy, (\\)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (catMaybes) import GHC.TypeLits (ErrorMessage(..)) -import Database.Persist.Types -import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity +import Database.Persist.Class.PersistStore +import Database.Persist.Types -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -419,10 +419,13 @@ insertBy val = do -- > +----+-------+-----+ insertUniqueEntity - :: forall record backend m. (MonadIO m - ,PersistRecordBackend record backend - ,PersistUniqueWrite backend) - => record -> ReaderT backend m (Maybe (Entity record)) + :: forall record backend m + . ( MonadIO m + , PersistRecordBackend record backend + , PersistUniqueWrite backend + ) + => record + -> ReaderT backend m (Maybe (Entity record)) insertUniqueEntity datum = fmap (\key -> Entity key datum) `liftM` insertUnique datum diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 7224f95db..ca2bfd164 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1870,10 +1870,15 @@ requirePersistentExtensions = requireExtensions requiredExtensions mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec] mkSymbolToFieldInstances mps ed = do - fmap join $ forM (entityFields ed) $ \fieldDef -> do - let fieldNameT = - litT $ strTyLit $ T.unpack $ unFieldNameHS $ fieldHaskell fieldDef - :: Q Type + fmap join $ forM (keyAndEntityFields ed) $ \fieldDef -> do + let fieldNameT :: Q Type + fieldNameT = + litT $ strTyLit + $ T.unpack $ lowerFirstIfId + $ unFieldNameHS $ fieldHaskell fieldDef + + lowerFirstIfId "Id" = "id" + lowerFirstIfId xs = xs nameG = mkEntityDefGenericName ed diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 2719a7983..073db1d1a 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.12.1.0 +version: 2.12.1.1 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs index c6989e65a..c2a4b4411 100644 --- a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs +++ b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs @@ -52,5 +52,11 @@ spec = describe "OverloadedLabels" $ do compiles + it "works for id labels" $ do + let UserId = #id + orgId = #id :: EntityField Organization OrganizationId + + compiles + compiles :: Expectation compiles = True `shouldBe` True