From 5a44a6d358db5e6df4f891e2fc90764784267f64 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 4 May 2021 22:36:28 +0100 Subject: [PATCH] Merge branch 'master' into persistent-2.13 --- persistent/ChangeLog.md | 7 +++- persistent/Database/Persist/Quasi/Internal.hs | 24 ++++++++---- persistent/Database/Persist/TH.hs | 24 ++++++++---- persistent/Database/Persist/Types/Base.hs | 1 + .../Database/Persist/TH/KindEntitiesSpec.hs | 38 +++++++++++++++++++ .../Persist/TH/KindEntitiesSpecImports.hs | 22 +++++++++++ persistent/test/Database/Persist/THSpec.hs | 3 +- persistent/test/main.hs | 22 +++++++++++ 8 files changed, 124 insertions(+), 17 deletions(-) create mode 100644 persistent/test/Database/Persist/TH/KindEntitiesSpec.hs create mode 100644 persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 96274c860..85099d643 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -73,9 +73,14 @@ `PersistEntity` for the inputs. This allows you to pass `EntityDef`s into `mkPersist` which have been previously defined, which allows the foreign field information to be generated more reliably across modules. + +## 2.12.1.2 + +* [#1258](https://github.com/yesodweb/persistent/pull/1258) + * Support promoted types in Quasi Quoter * [#1243](https://github.com/yesodweb/persistent/pull/1243) * Assorted cleanup of TH module -* [1242](https://github.com/yesodweb/persistent/pull/1242) +* [#1242](https://github.com/yesodweb/persistent/pull/1242) * Refactor setEmbedField to use do notation * [#1237](https://github.com/yesodweb/persistent/pull/1237) * Remove nonEmptyOrFail function from recent tests diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 7e3a898e3..d6a4660f4 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -84,15 +84,11 @@ parseFieldType t0 = | isSpace c -> parse1 $ T.dropWhile isSpace t' | c == '(' -> parseEnclosed ')' id t' | c == '[' -> parseEnclosed ']' FTList t' - | isUpper c -> - let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t - in PSSuccess (getCon a) b + | isUpper c || c == '\'' -> + let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t' + in PSSuccess (parseFieldTypePiece c a) b | otherwise -> PSFail $ show (c, t') - getCon t = - case T.breakOnEnd "." t of - (_, "") -> FTTypeCon Nothing t - ("", _) -> FTTypeCon Nothing t - (a, b) -> FTTypeCon (Just $ T.init a) b + goMany front t = case parse1 t of PSSuccess x t' -> goMany (front . (x:)) t' @@ -100,6 +96,18 @@ parseFieldType t0 = PSDone -> PSSuccess (front []) t -- _ -> +parseFieldTypePiece :: Char -> Text -> FieldType +parseFieldTypePiece fstChar rest = + case fstChar of + '\'' -> + FTTypePromoted rest + _ -> + let t = T.cons fstChar rest + in case T.breakOnEnd "." t of + (_, "") -> FTTypeCon Nothing t + ("", _) -> FTTypeCon Nothing t + (a, b) -> FTTypeCon (Just $ T.init a) b + data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) -- ^ Modify the Haskell-style name into a database-style name. diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 92537520d..421664f7d 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -376,6 +376,8 @@ mEmbedded _ (FTTypeCon Just{} _) = Left Nothing mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = maybe (Left Nothing) Right $ M.lookup name ents +mEmbedded ents (FTTypePromoted (EntityNameHS -> name)) = + Left Nothing mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded ents (FTApp x y) = @@ -1905,13 +1907,21 @@ maybeNullable :: FieldDef -> Bool maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr ftToType :: FieldType -> Type -ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t --- This type is generated from the Quasi-Quoter. --- Adding this special case avoids users needing to import Data.Int -ftToType (FTTypeCon (Just "Data.Int") "Int64") = ConT ''Int64 -ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t] -ftToType (FTApp x y) = ftToType x `AppT` ftToType y -ftToType (FTList x) = ListT `AppT` ftToType x +ftToType = \case + FTTypeCon Nothing t -> + ConT $ mkName $ T.unpack t + -- This type is generated from the Quasi-Quoter. + -- Adding this special case avoids users needing to import Data.Int + FTTypeCon (Just "Data.Int") "Int64" -> + ConT ''Int64 + FTTypeCon (Just m) t -> + ConT $ mkName $ unpack $ concat [m, ".", t] + FTTypePromoted t -> + PromotedT $ mkName $ T.unpack t + FTApp x y -> + ftToType x `AppT` ftToType y + FTList x -> + ListT `AppT` ftToType x infixr 5 ++ (++) :: Text -> Text -> Text diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index cd853bca5..372866360 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -256,6 +256,7 @@ parseFieldAttrs = fmap $ \case data FieldType = FTTypeCon (Maybe Text) Text -- ^ Optional module and name. + | FTTypePromoted Text | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord, Lift) diff --git a/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs b/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs new file mode 100644 index 000000000..8e05a00d8 --- /dev/null +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.KindEntitiesSpec where + +import Database.Persist.TH.KindEntitiesSpecImports +import TemplateTestImports + +mkPersist sqlSettings [persistLowerCase| + +Customer + name String + age Int + +CustomerTransfer + customerId CustomerId + moneyAmount (MoneyAmount 'CustomerOwned 'Debit) +|] + +spec :: Spec +spec = describe "KindEntities" $ do + it "should support DataKinds in entity definition" $ do + let mkTransfer :: CustomerId -> MoneyAmount 'CustomerOwned 'Debit -> CustomerTransfer + mkTransfer = CustomerTransfer + getAmount :: CustomerTransfer -> MoneyAmount 'CustomerOwned 'Debit + getAmount = customerTransferMoneyAmount + compiles + +compiles :: Expectation +compiles = True `shouldBe` True diff --git a/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs new file mode 100644 index 000000000..b545d2ccc --- /dev/null +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Database.Persist.TH.KindEntitiesSpecImports where + +import Data.Proxy +import qualified Data.Text as T +import TemplateTestImports + +data Owner = MerchantOwned | CustomerOwned +data AccountKind = Debit | Credit + +newtype MoneyAmount (a :: Owner) (b :: AccountKind) = MoneyAmount Rational + +instance PersistFieldSql (MoneyAmount a b) where + sqlType _ = sqlType (Proxy :: Proxy Rational) + +instance PersistField (MoneyAmount a b) where + toPersistValue (MoneyAmount n) = + toPersistValue n + fromPersistValue v = + MoneyAmount <$> fromPersistValue v diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 592fbcc82..1a27011ee 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -45,12 +45,12 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports - import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec +import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec @@ -145,6 +145,7 @@ instance Arbitrary Address where spec :: Spec spec = describe "THSpec" $ do + KindEntitiesSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 60d5200b2..c461b1b3d 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -405,6 +405,28 @@ Notification let [notificationForeignDef] = entityForeigns notification foreignConstraintNameDBName notificationForeignDef `shouldBe` ConstraintNameDB "notification_fk_noti_user" + describe "ticked types" $ do + it "should be able to parse ticked types" $ do + let simplifyField field = + (fieldHaskell field, fieldType field) + let tickedDefinition = [st| +CustomerTransfer + customerId CustomerId + moneyAmount (MoneyAmount 'Customer 'Debit) + currencyCode CurrencyCode + uuid TransferUuid +|] + let [customerTransfer] = parse lowerCaseSettings tickedDefinition + let expectedType = + FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit" + + (simplifyField <$> entityFields customerTransfer) `shouldBe` + [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId") + , (FieldNameHS "moneyAmount", expectedType) + , (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode") + , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid") + ] + describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")