Integrate #1258 into the persistent-2.13 branch

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

persistent/Database/Persist/Quasi/Internal.hs

@@ -100,22 +100,30 @@ 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'
             PSFail err -> PSFail err
             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.

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

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)

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")

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

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

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

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