From d3ca5617da570da5d313d2523e280662c0befd03 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Wed, 28 Apr 2021 20:49:23 +0100 Subject: [PATCH 1/7] Add a test, but don't use ticked types --- persistent/test/main.hs | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/persistent/test/main.hs b/persistent/test/main.hs index c5fb58aaa..36adc9285 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -363,6 +363,28 @@ Notification entityComments car `shouldBe` Just "This is a Car\n" entityComments vehicle `shouldBe` Nothing + 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` FTTypeCon Nothing "Customer" `FTApp` FTTypeCon Nothing "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") From 506563c19b9448d49eac2b8858a498e6ee3af6ae Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Wed, 28 Apr 2021 20:54:29 +0100 Subject: [PATCH 2/7] Tick those types --- persistent/Database/Persist/Quasi.hs | 2 +- persistent/test/main.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 9a6a88672..83dda9d0b 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -486,7 +486,7 @@ parseFieldType t0 = | isSpace c -> parse1 $ T.dropWhile isSpace t' | c == '(' -> parseEnclosed ')' id t' | c == '[' -> parseEnclosed ']' FTList t' - | isUpper c -> + | isUpper c || c == '\'' -> let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t in PSSuccess (getCon a) b | otherwise -> PSFail $ show (c, t') diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 36adc9285..b3c7f5ee5 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -370,13 +370,13 @@ Notification let tickedDefinition = [st| CustomerTransfer customerId CustomerId - moneyAmount (MoneyAmount Customer Debit) + moneyAmount (MoneyAmount 'Customer 'Debit) currencyCode CurrencyCode uuid TransferUuid |] let [customerTransfer] = parse lowerCaseSettings tickedDefinition let expectedType = - FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypeCon Nothing "Customer" `FTApp` FTTypeCon Nothing "Debit" + FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypeCon Nothing "'Customer" `FTApp` FTTypeCon Nothing "'Debit" (simplifyField <$> entityFields customerTransfer) `shouldBe` [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId") From 5638595d63c0109d9acd75896e9215c01b190209 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Wed, 28 Apr 2021 21:19:20 +0100 Subject: [PATCH 3/7] Refactor to use lambda case --- persistent/Database/Persist/TH.hs | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 06af53b68..b775fcd25 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -1758,13 +1758,19 @@ 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] + FTApp x y -> + ftToType x `AppT` ftToType y + FTList x -> + ListT `AppT` ftToType x infixr 5 ++ (++) :: Text -> Text -> Text From 7e141b9f76a687787a6d2088d87785e40b056012 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Wed, 28 Apr 2021 22:03:06 +0100 Subject: [PATCH 4/7] Satisfy ticket --- persistent/Database/Persist/Quasi.hs | 22 +++++++--- persistent/Database/Persist/TH.hs | 4 ++ persistent/Database/Persist/Types/Base.hs | 1 + .../Database/Persist/TH/KindEntitiesSpec.hs | 43 +++++++++++++++++++ .../Persist/TH/KindEntitiesSpecImports.hs | 21 +++++++++ persistent/test/Database/Persist/THSpec.hs | 6 ++- persistent/test/main.hs | 2 +- 7 files changed, 89 insertions(+), 10 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/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 83dda9d0b..9c2e617e1 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -487,14 +487,10 @@ parseFieldType t0 = | c == '(' -> parseEnclosed ')' id t' | c == '[' -> parseEnclosed ']' FTList t' | isUpper c || c == '\'' -> - let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t - in PSSuccess (getCon a) b + 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' @@ -502,6 +498,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) , psStrictFields :: !Bool diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index b775fcd25..625b0c63c 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -349,6 +349,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)) = + maybe (Left Nothing) Right $ M.lookup name ents mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded ents (FTApp x y) = @@ -1767,6 +1769,8 @@ ftToType = \case 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 -> diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 1f6054bc2..14ed127a5 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -264,6 +264,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..a8b9ce95d --- /dev/null +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +-- {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +-- {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +-- {-# LANGUAGE TypeFamilies #-} +{-# 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 "works" $ do + {- + let UserName = #name + OrganizationName = #name + DogName = #name +-} + 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..db4612e30 --- /dev/null +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Database.Persist.TH.KindEntitiesSpecImports where + +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 _ = SqlInt64 + +instance PersistField (MoneyAmount a b) where + toPersistValue (MoneyAmount n) = PersistRational n + fromPersistValue = \case + PersistRational n -> pure (MoneyAmount n) + x -> Left $ "Failed to read MoneyAmount: " <> (T.pack (show x)) diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index dd8930ba9..a06fb36bd 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -42,9 +42,10 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports -import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec -import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec +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 share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| @@ -131,6 +132,7 @@ instance Arbitrary Address where spec :: Spec spec = do + KindEntitiesSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec diff --git a/persistent/test/main.hs b/persistent/test/main.hs index b3c7f5ee5..aa842cf47 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -376,7 +376,7 @@ CustomerTransfer |] let [customerTransfer] = parse lowerCaseSettings tickedDefinition let expectedType = - FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypeCon Nothing "'Customer" `FTApp` FTTypeCon Nothing "'Debit" + FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit" (simplifyField <$> entityFields customerTransfer) `shouldBe` [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId") From fc01faa57108e2ca51ff11cd122eed272973d0af Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Wed, 28 Apr 2021 22:33:38 +0100 Subject: [PATCH 5/7] Support older GHC --- persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs index db4612e30..a8f00838e 100644 --- a/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs @@ -18,4 +18,4 @@ instance PersistField (MoneyAmount a b) where toPersistValue (MoneyAmount n) = PersistRational n fromPersistValue = \case PersistRational n -> pure (MoneyAmount n) - x -> Left $ "Failed to read MoneyAmount: " <> (T.pack (show x)) + x -> Left $ T.pack $ "Failed to read MoneyAmount: " ++ show x From 2e11e0b3b67fb2cf3947d9ff1120ea84ac5cb8b6 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 4 May 2021 18:50:50 +0100 Subject: [PATCH 6/7] Post review tweaks - Correct instances for MoneyAmount - Add some additional compiler checks to spec - Removed commented out code - Remove redundant logic in mEmbedded --- persistent/Database/Persist/TH.hs | 2 +- .../test/Database/Persist/TH/KindEntitiesSpec.hs | 15 +++++---------- .../Persist/TH/KindEntitiesSpecImports.hs | 11 ++++++----- 3 files changed, 12 insertions(+), 16 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 625b0c63c..0a8cfa44c 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -350,7 +350,7 @@ mEmbedded _ (FTTypeCon Just{} _) = mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = maybe (Left Nothing) Right $ M.lookup name ents mEmbedded ents (FTTypePromoted (EntityNameHS -> name)) = - maybe (Left Nothing) Right $ M.lookup name ents + Left Nothing mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded ents (FTApp x y) = diff --git a/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs b/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs index a8b9ce95d..8e05a00d8 100644 --- a/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpec.hs @@ -1,16 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} --- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} --- {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} --- {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.KindEntitiesSpec where @@ -31,12 +27,11 @@ CustomerTransfer spec :: Spec spec = describe "KindEntities" $ do - it "works" $ do - {- - let UserName = #name - OrganizationName = #name - DogName = #name --} + 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 diff --git a/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs index a8f00838e..b545d2ccc 100644 --- a/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs +++ b/persistent/test/Database/Persist/TH/KindEntitiesSpecImports.hs @@ -3,6 +3,7 @@ module Database.Persist.TH.KindEntitiesSpecImports where +import Data.Proxy import qualified Data.Text as T import TemplateTestImports @@ -12,10 +13,10 @@ data AccountKind = Debit | Credit newtype MoneyAmount (a :: Owner) (b :: AccountKind) = MoneyAmount Rational instance PersistFieldSql (MoneyAmount a b) where - sqlType _ = SqlInt64 + sqlType _ = sqlType (Proxy :: Proxy Rational) instance PersistField (MoneyAmount a b) where - toPersistValue (MoneyAmount n) = PersistRational n - fromPersistValue = \case - PersistRational n -> pure (MoneyAmount n) - x -> Left $ T.pack $ "Failed to read MoneyAmount: " ++ show x + toPersistValue (MoneyAmount n) = + toPersistValue n + fromPersistValue v = + MoneyAmount <$> fromPersistValue v From baa384807449282b6d3d133f422e612a155c0979 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 4 May 2021 19:27:59 +0100 Subject: [PATCH 7/7] Update changelog --- persistent/ChangeLog.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 256a3cd1d..aba9f2a54 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,9 +2,11 @@ ## Unreleased +* [#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