From 7ae2b2c26d8d0bb93a9568625741151273e5625f Mon Sep 17 00:00:00 2001 From: Daniel Trowbridge Date: Sat, 2 Dec 2023 15:11:14 +0000 Subject: [PATCH 1/3] Derive Lift instances for entities using StockStrategy --- 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 f4b0bde24..4c55a95aa 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1746,10 +1746,10 @@ mkKeyTypeDec mps entDef = do requirePersistentExtensions - -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1" + -- Always use StockStrategy for Lift/Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1" -- This is much better for debugging/logging purposes -- cf. https://github.com/yesodweb/persistent/issues/1104 - let alwaysStockStrategyTypeclasses = [''Show, ''Read] + let alwaysStockStrategyTypeclasses = [''Lift, ''Show, ''Read] deriveClauses = fmap (\typeclass -> if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses) then DerivClause (Just StockStrategy) [(ConT typeclass)] From 7a0ee4b04706478ac9a8854ee32e30159d944d16 Mon Sep 17 00:00:00 2001 From: Daniel Trowbridge Date: Sat, 2 Dec 2023 15:49:47 +0000 Subject: [PATCH 2/3] Add Lift instances to SQL BackendKeys --- persistent/Database/Persist/Sql/Orphan/PersistStore.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index ce89b8f2c..4df33e5ec 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -34,6 +35,7 @@ import Data.Text (Text, unpack) import qualified Data.Text as T import Data.Void (Void) import GHC.Generics (Generic) +import Language.Haskell.TH.Syntax (Lift) import Web.HttpApiData (FromHttpApiData, ToHttpApiData) import Web.PathPieces (PathPiece) @@ -121,17 +123,17 @@ fieldDBName = fieldDB . persistFieldDef instance PersistCore SqlBackend where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } - deriving stock (Show, Read, Eq, Ord, Generic) + deriving stock (Show, Read, Eq, Ord, Generic, Lift) deriving newtype (Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance PersistCore SqlReadBackend where newtype BackendKey SqlReadBackend = SqlReadBackendKey { unSqlReadBackendKey :: Int64 } - deriving stock (Show, Read, Eq, Ord, Generic) + deriving stock (Show, Read, Eq, Ord, Generic, Lift) deriving newtype (Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance PersistCore SqlWriteBackend where newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 } - deriving stock (Show, Read, Eq, Ord, Generic) + deriving stock (Show, Read, Eq, Ord, Generic, Lift) deriving newtype (Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance BackendCompatible SqlBackend SqlBackend where From 5bc265323c9712e982a4c7013b6fba6a3956a202 Mon Sep 17 00:00:00 2001 From: Daniel Trowbridge Date: Sat, 2 Dec 2023 15:53:38 +0000 Subject: [PATCH 3/3] Include Lift in stockClasses list --- 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 4c55a95aa..faea9a355 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1270,8 +1270,8 @@ dataTypeDec mps entityMap entDef = do stockClasses = Set.fromList (fmap mkName - [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable" - ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable + [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable", "Lift" + ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable, ''Lift ] )