diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 0b43685f9..926ba7fbd 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -71,9 +71,14 @@ * [#1255](https://github.com/yesodweb/persistent/pull/1255) * `mkPersist` now checks to see if an instance already exists for `PersistEntity` for the inputs. + +## 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 e6c843b7a..299a0cc04 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -100,15 +100,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' @@ -116,6 +112,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 dddaac81a..e6539858e 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -714,6 +714,8 @@ mEmbedded _ (FTTypeCon Just{} _) = Left Nothing mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents +mEmbedded ents (FTTypePromoted (EntityNameHS -> name)) = + Left Nothing mEmbedded ents (FTList x) = mEmbedded ents x mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) = @@ -2460,13 +2462,21 @@ maybeNullable :: UnboundFieldDef -> Bool maybeNullable fd = nullable (unboundFieldAttrs 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 ++ (++) :: Monoid m => m -> m -> m diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 0a560c360..a10add26d 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -405,6 +405,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/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 1c94b7f54..c0320cd41 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -378,6 +378,28 @@ Notification `shouldBe` ConstraintNameDB "notification_fk_noti_user" + describe "ticked types" $ do + it "should be able to parse ticked types" $ do + let simplifyField field = + (unboundFieldNameHS field, unboundFieldType 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 <$> unboundEntityFields 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") 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 de6a6b785..43ed1e253 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -45,17 +45,18 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports -import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec -import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec -import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec -import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec +import qualified Database.Persist.TH.EmbedSpec as EmbedSpec +import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec +import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec +import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec -import qualified Database.Persist.TH.EmbedSpec as EmbedSpec +import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec +import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec -- test to ensure we can have types ending in Id that don't trash the TH -- machinery @@ -166,6 +167,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 4db91e2ce..b898bc84d 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -2,10 +2,10 @@ module Main where import Test.Hspec -import qualified Database.Persist.THSpec as THSpec -import qualified Database.Persist.QuasiSpec as QuasiSpec import qualified Database.Persist.ClassSpec as ClassSpec import qualified Database.Persist.PersistValueSpec as PersistValueSpec +import qualified Database.Persist.QuasiSpec as QuasiSpec +import qualified Database.Persist.THSpec as THSpec main :: IO () main = hspec $ do