Support promoted types in Quasi Quoter

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

persistent/Database/Persist/Quasi.hs

@@ -486,22 +486,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)
     , psStrictFields :: !Bool

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)) =
+    Left Nothing
 mEmbedded ents (FTList x) =
     mEmbedded ents x
 mEmbedded ents (FTApp x y) =
@@ -1758,13 +1760,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

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)

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

@@ -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

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