diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 5d6ba3d9c..db04e3fb3 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -128,7 +128,7 @@ import Language.Haskell.TH.Lib (defaultBndrFlag) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) -import Web.PathPieces (PathMultiPiece, PathPiece(..)) +import Web.PathPieces (PathPiece(..)) import Database.Persist import Database.Persist.Class.PersistEntity @@ -1228,9 +1228,11 @@ dataTypeDec mps entityMap entDef = do pure dec where - stratFor n - | n `elem` stockClasses = Left n - | otherwise = Right n + stratFor n = + if n `elem` stockClasses then + Left n + else + Right n stockClasses = Set.fromList (fmap mkName @@ -1690,7 +1692,7 @@ mkLensClauses mps entDef _genDataType = do -- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec]) mkKeyTypeDec mps entDef = do - (instDecs, typeclasses) <- + (instDecs, i) <- if mpsGeneric mps then if not useNewtype then do pfDec <- pfInstD @@ -1710,15 +1712,15 @@ mkKeyTypeDec mps entDef = do requirePersistentExtensions - deriveClauses <- mapM (\typeclass -> - do let strategy = decideStrategy typeclass - case strategy of -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - ViaStrategy _ -> requireExtensions [[DerivingVia]] -#endif - _ -> pure () - pure $ DerivClause (Just strategy) [(ConT typeclass)] - ) typeclasses + -- Always use StockStrategy for 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] + deriveClauses = fmap (\typeclass -> + if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses) + then DerivClause (Just StockStrategy) [(ConT typeclass)] + else DerivClause (Just NewtypeStrategy) [(ConT typeclass)] + ) i #if MIN_VERSION_template_haskell(2,15,0) let kd = if useNewtype @@ -1764,7 +1766,7 @@ mkKeyTypeDec mps entDef = do requirePersistentExtensions alwaysInstances <- - -- See the "Always use StockStrategy" comment below, on why Show/Read use "stock" here + -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) deriving stock instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) @@ -1803,20 +1805,6 @@ mkKeyTypeDec mps entDef = do supplement :: [Name] -> [Name] supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) - -- Always use StockStrategy for 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 - decideStrategy :: Name -> DerivStrategy - decideStrategy typeclass - | typeclass `elem` [''Show, ''Read] = StockStrategy -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - | typeclass == ''PathMultiPiece = - ViaStrategy $ ConT ''ViaPersistEntity `AppT` recordType -#endif - | useNewtype = NewtypeStrategy - | otherwise = StockStrategy - -- | Returns 'True' if the key definition has less than 2 fields. -- -- @since 2.11.0.0 diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 2e1505add..605401cb9 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -170,7 +170,6 @@ test-suite test Database.Persist.PersistValueSpec Database.Persist.QuasiSpec Database.Persist.TH.CommentSpec - Database.Persist.TH.CompositeKeyPathMultiPieceSpec Database.Persist.TH.CompositeKeyStyleSpec Database.Persist.TH.DiscoverEntitiesSpec Database.Persist.TH.EmbedSpec diff --git a/persistent/test/Database/Persist/TH/CompositeKeyPathMultiPieceSpec.hs b/persistent/test/Database/Persist/TH/CompositeKeyPathMultiPieceSpec.hs deleted file mode 100644 index 712a673f3..000000000 --- a/persistent/test/Database/Persist/TH/CompositeKeyPathMultiPieceSpec.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0) - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} - -module Database.Persist.TH.CompositeKeyPathMultiPieceSpec (spec) where - -import Data.Text -import Database.Persist.Class.PersistEntity -import Database.Persist.TH -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck -import Web.PathPieces - -mkPersist sqlSettings {mpsDeriveInstances = [''PathMultiPiece]} - [persistLowerCase| - CompositeKeyEntity - keyField1 Int - keyField2 Int - Primary keyField1 keyField2 - |] - -spec :: Spec -spec = describe "CompositeKeyPathMultiPieceSpec" $ do - describe "fromPathMultiPiece" $ do - prop "orders fields correctly" $ \k1 k2 -> do - let key :: Maybe (Key CompositeKeyEntity) - key = fromPathMultiPiece (pack . show <$> [k1 :: Int, k2]) - compositeKeyEntityKeykeyField1 <$> key `shouldBe` Just k1 - compositeKeyEntityKeykeyField2 <$> key `shouldBe` Just k2 - let rejected :: Maybe (Key CompositeKeyEntity) - rejected = Nothing - prop "rejects paths with too many/few pieces" $ \n -> do - let badPath = Prelude.replicate (abs n) (pack "0") - abs n /= 2 ==> fromPathMultiPiece badPath `shouldBe` rejected - it "rejects paths with pieces of incorrect types" $ do - fromPathMultiPiece (pack <$> ["a", "0"]) `shouldBe` rejected - fromPathMultiPiece (pack <$> ["0", "a"]) `shouldBe` rejected - describe "toPathMultiPiece" $ do - prop "orders fields correctly" $ \k1 k2 -> do - let key = CompositeKeyEntityKey k1 k2 - path = toPathMultiPiece key - path `shouldBe` pack . show <$> [k1, k2] - -#else - -module Database.Persist.TH.CompositeKeyPathMultiPieceSpec (spec) where - -import Test.Hspec - -spec :: Spec -spec = describe "CompositeKeyPathMultiPieceSpec" $ do - pendingWith "DerivingVia not supported" - -#endif diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 965f63b55..2d84727b1 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -50,7 +50,6 @@ import TemplateTestImports import qualified Database.Persist.TH.CommentSpec as CommentSpec -import qualified Database.Persist.TH.CompositeKeyPathMultiPieceSpec as CompositeKeyPathMultiPieceSpec import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec