Implement typelit field definitions

persistent-mongoDB/test/main.hs

@@ -1,23 +1,24 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE DataKinds, ExistentialQuantification #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 import qualified Data.ByteString as BS
 import Data.IntMap (IntMap)
 import qualified Data.Text as T
 import Data.Time
 import Database.MongoDB (runCommand1)
-import Text.Blaze.Html
 import Test.QuickCheck
+import Text.Blaze.Html
 
 -- FIXME: should this be added? (RawMongoHelpers module wasn't used)
 -- import qualified RawMongoHelpers
@@ -52,6 +53,7 @@ import qualified PersistentTest
 import qualified Recursive
 import qualified RenameTest
 import qualified SumTypeTest
+import qualified TypeLitFieldDefsTest
 import qualified UpsertTest
 
 type Tuple = (,)
@@ -129,6 +131,7 @@ main = do
         (db' (deleteWhere ([] :: [Filter (LargeNumberTest.NumberGeneric backend)])))
     MaxLenTest.specsWith dbNoCleanup
     MaybeFieldDefsTest.specsWith dbNoCleanup
+    TypeLitFieldDefsTest.specsWith dbNoCleanup
     Recursive.specsWith (db' Recursive.cleanup)
 
     SumTypeTest.specsWith (dbNoCleanup) Nothing

persistent-mysql/test/main.hs

@@ -44,6 +44,7 @@ import qualified MpsCustomPrefixTest
 import qualified MpsNoPrefixTest
 import qualified PersistUniqueTest
 import qualified PersistentTest
+import qualified TypeLitFieldDefsTest
 -- FIXME: Not used... should it be?
 -- import qualified PrimaryTest
 import qualified RawSqlTest
@@ -126,6 +127,7 @@ main = do
             , UniqueTest.uniqueMigrate
             , MaxLenTest.maxlenMigrate
             , MaybeFieldDefsTest.maybeFieldDefMigrate
+            , TypeLitFieldDefsTest.typeLitFieldDefsMigrate
             , Recursive.recursiveMigrate
             , CompositeTest.compositeMigrate
             , PersistUniqueTest.migration
@@ -174,6 +176,7 @@ main = do
         LargeNumberTest.specsWith db
         UniqueTest.specsWith db
         MaybeFieldDefsTest.specsWith db
+        TypeLitFieldDefsTest.specsWith db
         MaxLenTest.specsWith db
         Recursive.specsWith db
         SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))

persistent-postgresql/test/PgInit.hs

@@ -47,42 +47,43 @@ import Init
        , MonadFail
        , RunDb
        , TestFn(..)
+       , UUID(..)
        , arbText
        , asIO
        , assertEmpty
        , assertNotEmpty
        , assertNotEqual
        , isTravis
        , liftA2
+       , sqlSettingsUuid
        , truncateTimeOfDay
        , truncateToMicro
        , truncateUTCTime
        , (==@)
        , (@/=)
        , (@==)
-       , UUID(..)
-       , sqlSettingsUuid
        )
 
 -- re-exports
 import Control.Exception (SomeException)
 import Control.Monad (forM_, liftM, replicateM, void, when)
 import Control.Monad.Trans.Reader
-import Data.Aeson (ToJSON, FromJSON, Value(..))
+import Data.Aeson (FromJSON, ToJSON, Value(..))
+import qualified Data.Text.Encoding as TE
 import Database.Persist.Postgresql.JSON ()
 import Database.Persist.Sql.Raw.QQ
 import Database.Persist.SqlBackend
 import Database.Persist.TH
        ( MkPersistSettings(..)
-       , mkMigrate
        , migrateModels
+       , mkEntityDefList
+       , mkMigrate
        , mkPersist
        , persistLowerCase
        , persistUpperCase
+       , setImplicitIdDef
        , share
        , sqlSettings
-       , setImplicitIdDef
-       , mkEntityDefList
        )
 import Test.Hspec
        ( Arg
@@ -101,7 +102,6 @@ import Test.Hspec
 import Test.Hspec.Expectations.Lifted
 import Test.QuickCheck.Instances ()
 import UnliftIO
-import qualified Data.Text.Encoding as TE
 
 -- testing
 import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=))

persistent-postgresql/test/main.hs

@@ -57,6 +57,7 @@ import qualified RenameTest
 import qualified SumTypeTest
 import qualified TransactionLevelTest
 import qualified TreeTest
+import qualified TypeLitFieldDefsTest
 import qualified UniqueTest
 import qualified UpsertTest
 import qualified UpsertWhere
@@ -120,6 +121,7 @@ main = do
       , UniqueTest.uniqueMigrate
       , MaxLenTest.maxlenMigrate
       , MaybeFieldDefsTest.maybeFieldDefMigrate
+      , TypeLitFieldDefsTest.typeLitFieldDefsMigrate
       , Recursive.recursiveMigrate
       , CompositeTest.compositeMigrate
       , TreeTest.treeMigrate
@@ -173,6 +175,7 @@ main = do
       UniqueTest.specsWith runConnAssert
       MaxLenTest.specsWith runConnAssert
       MaybeFieldDefsTest.specsWith runConnAssert
+      TypeLitFieldDefsTest.specsWith runConnAssert
       Recursive.specsWith runConnAssert
       SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
       MigrationTest.specsWith runConnAssert

persistent-sqlite/test/main.hs

@@ -45,6 +45,7 @@ import qualified Recursive
 import qualified RenameTest
 import qualified SumTypeTest
 import qualified TransactionLevelTest
+import qualified TypeLitFieldDefsTest
 import qualified UniqueTest
 import qualified UpsertTest
 
@@ -162,6 +163,7 @@ main = do
             , UniqueTest.uniqueMigrate
             , MaxLenTest.maxlenMigrate
             , MaybeFieldDefsTest.maybeFieldDefMigrate
+            , TypeLitFieldDefsTest.typeLitFieldDefsMigrate
             , Recursive.recursiveMigrate
             , CompositeTest.compositeMigrate
             , MigrationTest.migrationMigrate
@@ -209,6 +211,7 @@ main = do
         UniqueTest.specsWith db
         MaxLenTest.specsWith db
         MaybeFieldDefsTest.specsWith db
+        TypeLitFieldDefsTest.specsWith db
         Recursive.specsWith db
         SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
         MigrationOnlyTest.specsWith db

persistent-test/persistent-test.cabal

@@ -53,6 +53,7 @@ library
         SumTypeTest
         TransactionLevelTest
         TreeTest
+        TypeLitFieldDefsTest
         UniqueTest
         UpsertTest
         LongIdentifierTest

persistent-test/src/TypeLitFieldDefsTest.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+module TypeLitFieldDefsTest (specsWith, typeLitFieldDefsMigrate) where
+
+import Data.Maybe (fromJust)
+import GHC.TypeNats
+import Init
+
+newtype Finite (n :: Nat) = Finite Int
+  deriving (Show, Eq)
+
+instance PersistField (Finite n) where
+    toPersistValue (Finite n) = toPersistValue n
+    fromPersistValue = fmap Finite . fromPersistValue
+
+instance PersistFieldSql (Finite n) where
+    sqlType _ = sqlType (Proxy :: Proxy Int)
+
+newtype Labelled (t :: Symbol) = Labelled Int
+
+instance PersistField (Labelled n) where
+    toPersistValue (Labelled n) = toPersistValue n
+    fromPersistValue = fmap Labelled . fromPersistValue
+
+instance PersistFieldSql (Labelled n) where
+    sqlType _ = sqlType (Proxy :: Proxy Int)
+
+share [mkPersist sqlSettings { mpsGeneric = True },  mkMigrate "typeLitFieldDefsMigrate"] [persistLowerCase|
+  TypeLitFieldDefsNumeric
+    one    (Finite 1)
+    twenty (Finite 20)
+    deriving Eq Show
+
+  TypeLitFieldDefsLabelled
+    one    (Labelled "one")
+    twenty (Labelled "twenty")
+    deriving Eq Show
+|]
+
+one :: Finite 1
+one = Finite 1
+
+oneLabelled :: Labelled "one"
+oneLabelled = Labelled 1
+
+twenty :: Finite 20
+twenty = Finite 20
+
+twentyLabelled :: Labelled "twenty"
+twentyLabelled = Labelled 20
+
+specsWith :: Runner backend m => RunDb backend m -> Spec
+specsWith runDb =
+  describe "Type Lit Field Definitions" $ do
+    it "runs appropriate migrations" $ runDb $ do
+      numKey <- insert $ TypeLitFieldDefsNumeric one twenty
+      num <- getJust numKey
+      liftIO $ typeLitFieldDefsEntityNumeric num @?= one
+      liftIO $ typeLitFieldDefsEntityNumeric num @?= twenty
+
+      labelledKey <- insert $ TypeLitFieldDefsLabelled one twenty
+      lbl <- getJust labelledKey
+      liftIO $ typeLitFieldDefsEntityLabelled lbl @?= oneLabelled
+      liftIO $ typeLitFieldDefsEntityLabelled lbl @?= twentyLabelled
+

persistent/Database/Persist/Quasi/Internal.hs

@@ -52,8 +52,8 @@ module Database.Persist.Quasi.Internal
 import Prelude hiding (lines)
 
 import Control.Applicative (Alternative((<|>)))
-import Control.Monad (mplus)
-import Data.Char (isLower, isSpace, isUpper, toLower)
+import Control.Monad (guard, mplus)
+import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)
 import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NEL
@@ -65,7 +65,7 @@ import qualified Data.Text as T
 import Database.Persist.EntityDef.Internal
 import Database.Persist.Types
 import Language.Haskell.TH.Syntax (Lift)
-import Text.Read (readEither)
+import qualified Text.Read as R
 
 data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show
 
@@ -95,25 +95,55 @@ parseFieldType t0 =
           x -> PSFail $ show x
 
     parse1 :: Text -> ParseState FieldType
-    parse1 t =
+    parse1 t = fromMaybe (PSFail (show t)) $ do
         case T.uncons t of
-            Nothing -> PSDone
-            Just (c, t')
-                | isSpace c -> parse1 $ T.dropWhile isSpace t'
-                | 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 (parseFieldTypePiece c a) b
-                | otherwise -> PSFail $ show (c, t')
+          Nothing -> pure PSDone
+          Just (x, xs) ->
+            parseSpace x xs
+            <|> parseParenEnclosed x xs
+            <|> parseList x xs
+            <|> parseNumericLit x xs
+            <|> parseTextLit x xs
+            <|> parseTypeCon x xs
+
+    parseSpace :: Char -> Text -> Maybe (ParseState FieldType)
+    parseSpace c t = do
+        guard (isSpace c)
+        pure $ parse1 (T.dropWhile isSpace t)
+
+    parseParenEnclosed c t = do
+        guard (c == '(')
+        pure $ parseEnclosed ')' id t
+
+    parseList c t = do
+        guard (c == '[')
+        pure $ parseEnclosed ']' FTList t
+
+    parseTextLit :: Char -> Text -> Maybe (ParseState FieldType)
+    parseTextLit c t = do
+        guard (c == '"')
+        let (a, b) = T.break (== '"') t
+            lit = FTLit (TextTypeLit a)
+        pure $ PSSuccess lit (T.drop 1 b)
+
+    parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType)
+    parseNumericLit c t = do
+        guard (isDigit c && T.all isDigit t)
+        let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t
+        lit <- FTLit . IntTypeLit <$> readMaybe (T.cons c a)
+        pure $ PSSuccess lit b
+
+    parseTypeCon c t = do
+        guard (isUpper c || c == '\'')
+        let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t
+        pure $ PSSuccess (parseFieldTypePiece c a) b
 
     goMany :: ([FieldType] -> a) -> Text -> ParseState a
     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 =
@@ -1362,11 +1392,7 @@ parseCascadeAction
     -> Maybe CascadeAction
 parseCascadeAction prfx text = do
     cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text
-    case readEither (T.unpack cascadeStr) of
-        Right a ->
-            Just a
-        Left _ ->
-            Nothing
+    readMaybe cascadeStr
   where
     toPrefix cp =
         case cp of
@@ -1391,3 +1417,6 @@ isHaskellUnboundField fd =
 -- @since 2.13.0.0
 getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS
 getUnboundEntityNameHS = entityHaskell . unboundEntityDef
+
+readMaybe :: Read a => Text -> Maybe a
+readMaybe = R.readMaybe . T.unpack

persistent/Database/Persist/TH.hs

@@ -2619,13 +2619,20 @@ ftToType = \case
         ConT ''Int64
     FTTypeCon (Just m) t ->
         ConT $ mkName $ unpack $ concat [m, ".", t]
+    FTLit l ->
+        LitT (typeLitToTyLit l)
     FTTypePromoted t ->
         PromotedT $ mkName $ T.unpack t
     FTApp x y ->
         ftToType x `AppT` ftToType y
     FTList x ->
         ListT `AppT` ftToType x
 
+typeLitToTyLit :: FieldTypeLit -> TyLit
+typeLitToTyLit = \case
+  IntTypeLit n -> NumTyLit n
+  TextTypeLit t -> StrTyLit (T.unpack t)
+
 infixr 5 ++
 (++) :: Monoid m => m -> m -> m
 (++) = mappend

persistent/Database/Persist/Types.hs

@@ -48,6 +48,8 @@ import Database.Persist.PersistValue
 -- this module is a bit of a kitchen sink of types and concepts. the guts of
 -- persistent, just strewn across the table. in 2.13 let's get this cleaned up
 -- and a bit more tidy.
+--
+-- not sure if the re-export of FieldTypeLit here is correct going forward, given the above
 import Database.Persist.Types.Base
        ( Attr
        , CascadeAction(..)
@@ -60,6 +62,7 @@ import Database.Persist.Types.Base
        , FieldCascade(..)
        , FieldDef(..)
        , FieldType(..)
+       , FieldTypeLit(..)
        , ForeignDef(..)
        , ForeignFieldDef
        , IsNullable(..)