From f3a7935cf64f0f3d54b91017d1120ff01a5714a0 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 17:22:11 +0100 Subject: [PATCH 01/12] Refactor to result type --- persistent/Database/Persist/TH.hs | 34 ++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index ca2bfd164..1038b94d7 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1077,6 +1077,7 @@ fieldError tableName fieldName err = mconcat mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] mkEntity entityMap mps entDef = do + fields <- mkFields mps entDef entityDefExp <- if mpsGeneric mps then liftAndFixKeys entityMap entDef @@ -1087,8 +1088,6 @@ mkEntity entityMap mps entDef = do fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef - let primaryField = entityId entDef - fields <- mapM (mkField mps entDef) $ primaryField : entityFields entDef fkc <- mapM (mkForeignKeysComposite mps entDef) $ entityForeigns entDef toFieldNames <- mkToFieldNames $ entityUniques entDef @@ -1132,6 +1131,8 @@ mkEntity entityMap mps entDef = do [d|$(varP 'keyFromRecordM) = Nothing|] dtd <- dataTypeDec mps entDef + let allEntDefs = entityFieldTHCon <$> efthAllFields fields + allEntDefClauses = entityFieldTHClause <$> efthAllFields fields return $ addSyn $ dtd : mconcat fkc `mappend` ([ TySynD (keyIdName entDef) [] $ @@ -1154,7 +1155,7 @@ mkEntity entityMap mps entDef = do Nothing (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) Nothing - (map fst fields) + allEntDefs [] #else , DataInstD @@ -1164,10 +1165,10 @@ mkEntity entityMap mps entDef = do , VarT $ mkName "typ" ] Nothing - (map fst fields) + allEntDefs [] #endif - , FunD 'persistFieldDef (map snd fields) + , FunD 'persistFieldDef allEntDefClauses #if MIN_VERSION_template_haskell(2,15,0) , TySynInstD (TySynEqn @@ -1189,6 +1190,20 @@ mkEntity entityMap mps entDef = do genDataType = genericDataType mps entName backendT entName = entityHaskell entDef +data EntityFieldsTH = EntityFieldsTH + { entityFieldsTHPrimary :: EntityFieldTH + , entityFieldsTHFields :: [EntityFieldTH] + } + +efthAllFields :: EntityFieldsTH -> [EntityFieldTH] +efthAllFields EntityFieldsTH{..} = entityFieldsTHPrimary : entityFieldsTHFields + +mkFields :: MkPersistSettings -> EntityDef -> Q EntityFieldsTH +mkFields mps entDef = + EntityFieldsTH + <$> mkField mps entDef (entityId entDef) + <*> mapM (mkField mps entDef) (entityFields entDef) + mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec] mkUniqueKeyInstances mps entDef = do requirePersistentExtensions @@ -1712,13 +1727,18 @@ liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = _ -> Nothing +data EntityFieldTH = EntityFieldTH + { entityFieldTHCon :: Con + , entityFieldTHClause :: Clause + } + -- Ent -- fieldName FieldType -- -- forall . typ ~ FieldType => EntFieldName -- -- EntFieldName = FieldDef .... -mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause) +mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q EntityFieldTH mkField mps et cd = do let con = ForallC [] @@ -1728,7 +1748,7 @@ mkField mps et cd = do let cla = normalClause [ConP name []] bod - return (con, cla) + return $ EntityFieldTH con cla where name = filterConName mps et cd From 21cc16ede733fee5bd174814e2bf4f8cb1ce0802 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:01:46 +0100 Subject: [PATCH 02/12] Refactor liftandfixkeys --- persistent/Database/Persist/TH.hs | 34 +++++++++++++++++++------------ 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 1038b94d7..37c52c292 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1082,6 +1082,7 @@ mkEntity entityMap mps entDef = do if mpsGeneric mps then liftAndFixKeys entityMap entDef else makePersistEntityDefExp mps entityMap entDef + let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType tpf <- mkToPersistFields mps entDef @@ -1135,7 +1136,7 @@ mkEntity entityMap mps entDef = do allEntDefClauses = entityFieldTHClause <$> efthAllFields fields return $ addSyn $ dtd : mconcat fkc `mappend` - ([ TySynD (keyIdName entDef) [] $ + ( [ TySynD (keyIdName entDef) [] $ ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entDef @@ -1711,21 +1712,28 @@ liftAndFixKeys entityMap EntityDef{..} = |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = - [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|] +liftAndFixKey entityMap fd@(FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = + [|FieldDef a b c $(sqlTyp') e f fieldRef' fc mcomments fg|] where - (fieldRef', sqlTyp') = - fromMaybe (fieldRef, lift sqlTyp) $ - case fieldRef of - ForeignRef refName _ft -> do - ent <- M.lookup refName entityMap - case fieldReference $ entityId ent of - fr@(ForeignRef _ ft) -> - Just (fr, lift $ SqlTypeExp ft) - _ -> - Nothing + (fieldRef', sqlTyp') = + case extractForeignRef entityMap fd of + Just (fr, ft) -> + (fr, lift (SqlTypeExp ft)) + Nothing -> + (fieldRef, lift sqlTyp) + +extractForeignRef :: EntityMap -> FieldDef -> Maybe (ReferenceDef, FieldType) +extractForeignRef entityMap fieldDef = + case fieldReference fieldDef of + ForeignRef refName _ft -> do + ent <- M.lookup refName entityMap + case fieldReference $ entityId ent of + fr@(ForeignRef _ ft) -> + Just (fr, ft) _ -> Nothing + _ -> + Nothing data EntityFieldTH = EntityFieldTH { entityFieldTHCon :: Con From 4eac128a097876dc2b078709a9a3d8dfa184b85c Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:03:32 +0100 Subject: [PATCH 03/12] Extract function --- persistent/Database/Persist/TH.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 37c52c292..46e108457 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -191,7 +191,7 @@ embedEntityDefs = snd . embedEntityDefsMap embedEntityDefsMap :: [EntityDef] -> (M.Map EntityNameHS EmbedEntityDef, [EntityDef]) embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) where - noCycleEnts = map breakCycleEnt entsWithEmbeds + noCycleEnts = map breakEntDefCycle entsWithEmbeds -- every EntityDef could reference each-other (as an EmbedRef) -- let Haskell tie the knot embedEntityMap = constructEmbedEntityMap entsWithEmbeds @@ -200,12 +200,15 @@ embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent } - -- self references are already broken - -- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS - -- so start with entityHaskell ent and accumulate embeddedHaskell em - breakCycleEnt entDef = - let entName = entityHaskell entDef - in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef } +-- self references are already broken +-- look at every emFieldEmbed to see if it refers to an already seen EntityNameHS +-- so start with entityHaskell ent and accumulate embeddedHaskell em +breakEntDefCycle :: EntityDef -> EntityDef +breakEntDefCycle entDef = + entDef { entityFields = breakCycleField entName <$> entityFields entDef } + where + entName = + entityHaskell entDef breakCycleField entName f = case f of FieldDef { fieldReference = EmbedRef em } -> From 92483bad467f70cc3d5f993e7e70d088e3d74935 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:05:36 +0100 Subject: [PATCH 04/12] Typesig/alignment fixing --- persistent/Database/Persist/TH.hs | 49 +++++++++++++++++-------------- 1 file changed, 27 insertions(+), 22 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 46e108457..781e50d7f 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -671,11 +671,12 @@ mkUnique mps entDef (UniqueDef constr _ fields attrs) = , "on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -maybeIdType :: MkPersistSettings - -> FieldDef - -> Maybe Name -- ^ backend - -> Maybe IsNullable - -> Type +maybeIdType + :: MkPersistSettings + -> FieldDef + -> Maybe Name -- ^ backend + -> Maybe IsNullable + -> Type maybeIdType mps fieldDef mbackend mnull = maybeTyp mayNullable idtyp where mayNullable = case mnull of @@ -1363,18 +1364,17 @@ maybeTyp :: Bool -> Type -> Type maybeTyp may typ | may = ConT ''Maybe `AppT` typ | otherwise = typ - - entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues where columnNames = map (unFieldNameHS . fieldHaskell) (entityFields (entityDef (Just entity))) fieldsAsPersistValues = map toPersistValue $ toPersistFields entity -entityFromPersistValueHelper :: (PersistEntity record) - => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code - -> PersistValue - -> Either Text record +entityFromPersistValueHelper + :: (PersistEntity record) + => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code + -> PersistValue + -> Either Text record entityFromPersistValueHelper columnNames pv = do (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv @@ -1561,9 +1561,12 @@ sqlTypeFunD :: Exp -> Dec sqlTypeFunD st = FunD 'sqlType [ normalClause [WildP] st ] -typeInstanceD :: Name - -> Bool -- ^ include PersistStore backend constraint - -> Type -> [Dec] -> Dec +typeInstanceD + :: Name + -> Bool -- ^ include PersistStore backend constraint + -> Type + -> [Dec] + -> Dec typeInstanceD clazz hasBackend typ = instanceD ctx (ConT clazz `AppT` typ) where @@ -2078,16 +2081,18 @@ 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 + :: MkPersistSettings + -> EntityDef + -> FieldDef + -> Name filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) -filterConName' :: MkPersistSettings - -> EntityNameHS - -> FieldNameHS - -> Name +filterConName' + :: MkPersistSettings + -> EntityNameHS + -> FieldNameHS + -> Name filterConName' mps entity field = mkName $ T.unpack name where name From c24d743ce4c98610b62a2e99f54ff5db0f0228b8 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:05:51 +0100 Subject: [PATCH 05/12] Missed a spot --- persistent/Database/Persist/TH.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 781e50d7f..cd2884f92 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1798,7 +1798,7 @@ mkJSON mps def = do xs <- mapM fieldToJSONValName (entityFields def) - let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def + let conName = mkEntityDefName def typ = genericDataType mps (entityHaskell def) backendT toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] toJSON' = FunD 'toJSON $ return $ normalClause @@ -2099,6 +2099,7 @@ filterConName' mps entity field = mkName $ T.unpack name | field == FieldNameHS "Id" = entityName ++ fieldName | mpsPrefixFields mps = modifiedName | otherwise = fieldName + modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unEntityNameHS entity - fieldName = upperFirst $ unFieldNameHS field + entityName = unEntityNameHS entity + fieldName = upperFirst $ unFieldNameHS field From b907779e3a4667ea8d3316c48ea89a37ed2d42ac Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:06:32 +0100 Subject: [PATCH 06/12] Inline function --- persistent/Database/Persist/TH.hs | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index cd2884f92..e4fcd4840 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -554,14 +554,6 @@ recNameNoUnderscore mps entName fieldName modifier = mpsFieldLabelModifier mps ft = unFieldNameHS fieldName -recNameF :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text -recNameF mps entName fieldName = - addUnderscore $ recNameNoUnderscore mps entName fieldName - where - addUnderscore - | mpsGenerateLenses mps = ("_" ++) - | otherwise = id - lowerFirst :: Text -> Text lowerFirst t = case uncons t of @@ -1999,11 +1991,17 @@ entityDefConE = ConE . mkEntityDefName -- -- 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 +fieldNameToRecordName mps entDef fieldName = + mkName $ T.unpack $ addUnderscore $ recNameNoUnderscore mps (entityHaskell entDef) fieldName + where + addUnderscore + | mpsGenerateLenses mps = ("_" ++) + | otherwise = id -- | as above, only takes a `FieldDef` fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef) +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] From 6291d405f9846a87ee10e1388e25c4afc550f0c3 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:06:46 +0100 Subject: [PATCH 07/12] Extract more stuff --- persistent/Database/Persist/TH.hs | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index e4fcd4840..af185d160 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1279,7 +1279,7 @@ 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 = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) + let lensName = mkEntityLensName mps ent field fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter" @@ -2003,6 +2003,19 @@ fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef) +-- | creates a TH Name for a lens on an entity's field, based on the entity +-- name and the field name, so as above but for the Lens +-- +-- Customer +-- name Text +-- +-- Generates a lens `customerName` when `mpsGenerateLenses` is true +-- while `fieldNameToRecordName` generates a prefixed function +-- `_customerName` +mkEntityLensName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +mkEntityLensName mps entDef fieldDef = + mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell entDef) (fieldHaskell fieldDef) + -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name] mkEntityDefDeriveNames mps entDef = From 3310323260ccc26fb7f19060f954e0239e7fa0cd Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:08:49 +0100 Subject: [PATCH 08/12] Subsume record name generating function --- persistent/Database/Persist/TH.hs | 35 +++++++++++++++++++------------ 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index af185d160..aa11ed904 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -546,14 +546,6 @@ mkPersistSettings backend = MkPersistSettings sqlSettings :: MkPersistSettings sqlSettings = mkPersistSettings $ ConT ''SqlBackend -recNameNoUnderscore :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Text -recNameNoUnderscore mps entName fieldName - | mpsPrefixFields mps = lowerFirst $ modifier (unEntityNameHS entName) (upperFirst ft) - | otherwise = lowerFirst ft - where - modifier = mpsFieldLabelModifier mps - ft = unFieldNameHS fieldName - lowerFirst :: Text -> Text lowerFirst t = case uncons t of @@ -1992,11 +1984,11 @@ entityDefConE = ConE . mkEntityDefName -- This would generate `customerName` as a TH Name fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name fieldNameToRecordName mps entDef fieldName = - mkName $ T.unpack $ addUnderscore $ recNameNoUnderscore mps (entityHaskell entDef) fieldName + mkRecordName mps mUnderscore (entityHaskell entDef) fieldName where - addUnderscore - | mpsGenerateLenses mps = ("_" ++) - | otherwise = id + mUnderscore + | mpsGenerateLenses mps = Just "_" + | otherwise = Nothing -- | as above, only takes a `FieldDef` fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name @@ -2014,7 +2006,24 @@ fieldDefToRecordName mps entDef fieldDef = -- `_customerName` mkEntityLensName :: MkPersistSettings -> EntityDef -> FieldDef -> Name mkEntityLensName mps entDef fieldDef = - mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell entDef) (fieldHaskell fieldDef) + mkRecordName mps Nothing (entityHaskell entDef) (fieldHaskell fieldDef) + +mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name +mkRecordName mps prefix entNameHS fieldNameHS = + mkName $ T.unpack $ fromMaybe "" prefix <> lowerFirst recName + where + recName :: Text + recName + | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) + | otherwise = fieldNameText + + entityNameText :: Text + entityNameText = + unEntityNameHS entNameHS + + fieldNameText :: Text + fieldNameText = + unFieldNameHS fieldNameHS -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name] From 4394da2b34d30c608ad23aa0b7f70e80c1f2d4e3 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:11:58 +0100 Subject: [PATCH 09/12] Remove exceessive extra spaces --- persistent/Database/Persist/TH.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index aa11ed904..fde8a3716 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -733,7 +733,6 @@ mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } ] return $ normalClause [ConP name [VarP x]] body - mkToFieldNames :: [UniqueDef] -> Q Dec mkToFieldNames pairs = do pairs' <- mapM go pairs @@ -1466,8 +1465,6 @@ mkDeleteCascade mps defs = do val (Nullable ByMaybeAttr) = just `AppE` VarE key val _ = VarE key - - let stmts :: [Stmt] stmts = map mkStmt deps `mappend` [NoBindS $ del `AppE` VarE key] @@ -1856,7 +1853,6 @@ instanceD = InstanceD Nothing -- pu' <- lift pu -- return $ normalClause [RecP (mkName constr) []] pu' - -- mkToFieldName :: String -> [(String, String)] -> Dec -- mkToFieldName func pairs = -- FunD (mkName func) $ degen $ map go pairs From b8d05bec5a9ecb7e81b7a6eae00235a6e366becc Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:33:33 +0100 Subject: [PATCH 10/12] Rename to clearer value --- persistent/Database/Persist/TH.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index fde8a3716..dfe1ac05c 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1699,11 +1699,11 @@ liftAndFixKeys entityMap EntityDef{..} = |] liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap fd@(FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = +liftAndFixKey entityMap fieldDef@(FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = [|FieldDef a b c $(sqlTyp') e f fieldRef' fc mcomments fg|] where (fieldRef', sqlTyp') = - case extractForeignRef entityMap fd of + case extractForeignRef entityMap fieldDef of Just (fr, ft) -> (fr, lift (SqlTypeExp ft)) Nothing -> From 0fdc52577a84f38baef66aaa492e4498ffd879f9 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:36:09 +0100 Subject: [PATCH 11/12] Run stylish haskell on file --- persistent/Database/Persist/TH.hs | 55 +++++++++++++++++-------------- 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index dfe1ac05c..0ae46dcc1 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE ViewPatterns #-} -- {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} @@ -61,48 +61,55 @@ module Database.Persist.TH -- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code -- It's highly recommended to check the diff between master and your PR's generated code. -import Prelude hiding ((++), take, concat, splitAt, exp) +import Prelude hiding (concat, exp, splitAt, take, (++)) -import Data.Either import Control.Monad import Data.Aeson - ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object - , Value (Object), (.:), (.:?) - , eitherDecodeStrict' - ) + ( FromJSON(parseJSON) + , ToJSON(toJSON) + , Value(Object) + , eitherDecodeStrict' + , object + , (.:) + , (.:?) + , (.=) + ) import qualified Data.ByteString as BS -import Data.Typeable (Typeable) -import Data.Ix (Ix) -import Data.Data (Data) import Data.Char (toLower, toUpper) +import Data.Data (Data) +import Data.Either import qualified Data.HashMap.Strict as HM import Data.Int (Int64) +import Data.Ix (Ix) import Data.List (foldl') import qualified Data.List as List import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) -import Data.Monoid ((<>), mappend, mconcat) -import Data.Proxy (Proxy (Proxy)) -import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix) +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) +import Data.Monoid (mappend, mconcat, (<>)) +import Data.Proxy (Proxy(Proxy)) +import Data.Text (Text, append, concat, cons, pack, stripSuffix, uncons, unpack) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) import GHC.Generics (Generic) 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, conK, conT, varE, varP, conE, litT, strTyLit) +import qualified Data.Set as Set +import Language.Haskell.TH.Lib + (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax +import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) -import qualified Data.Set as Set import Database.Persist -import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.Quasi +import Database.Persist.Sql + (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). From 4d05276b7a84d839a52325ab11d412a838fd5d1f Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Thu, 22 Apr 2021 18:38:47 +0100 Subject: [PATCH 12/12] Update changelog --- persistent/ChangeLog.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 951eaf947..f2c376a37 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## Unreleased + +* [#1243](https://github.com/yesodweb/persistent/pull/1243) + * Assorted cleanup of TH module + ## 2.12.1.1 * [#1231](https://github.com/yesodweb/persistent/pull/1231)