Implement Type Literal based field definitions (#1343)

* Implement typelit field definitions

* Some cleanup

* Sort indentation and add PR link in changelog

* Move location of exposed type

Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>

persistent-mongoDB/test/main.hs

@@ -1,24 +1,25 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE DataKinds, ExistentialQuantification #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# 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
@@ -53,6 +54,7 @@ import qualified PersistentTest
 import qualified Recursive
 import qualified RenameTest
 import qualified SumTypeTest
+import qualified TypeLitFieldDefsTest
 import qualified UpsertTest
 
 type Tuple = (,)
@@ -130,6 +132,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

@@ -46,6 +46,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
@@ -129,6 +130,7 @@ main = do
             , UniqueTest.uniqueMigrate
             , MaxLenTest.maxlenMigrate
             , MaybeFieldDefsTest.maybeFieldDefMigrate
+            , TypeLitFieldDefsTest.typeLitFieldDefsMigrate
             , Recursive.recursiveMigrate
             , CompositeTest.compositeMigrate
             , PersistUniqueTest.migration
@@ -178,6 +180,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

@@ -48,42 +48,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(..), object)
+import Data.Aeson (FromJSON, ToJSON, Value(..), object)
+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
@@ -102,7 +103,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

@@ -58,6 +58,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
@@ -121,6 +122,7 @@ main = do
       , UniqueTest.uniqueMigrate
       , MaxLenTest.maxlenMigrate
       , MaybeFieldDefsTest.maybeFieldDefMigrate
+      , TypeLitFieldDefsTest.typeLitFieldDefsMigrate
       , Recursive.recursiveMigrate
       , CompositeTest.compositeMigrate
       , TreeTest.treeMigrate
@@ -174,6 +176,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.TypeLits
+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
+    deriving (Show, Eq)
+
+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 $ typeLitFieldDefsNumericOne num @?= one
+            liftIO $ typeLitFieldDefsNumericTwenty num @?= twenty
+
+            labelledKey <- insert $ TypeLitFieldDefsLabelled oneLabelled twentyLabelled
+            lbl <- getJust labelledKey
+            liftIO $ typeLitFieldDefsLabelledOne lbl @?= oneLabelled
+            liftIO $ typeLitFieldDefsLabelledTwenty lbl @?= twentyLabelled

persistent/ChangeLog.md

@@ -2,6 +2,8 @@
 
 ## 2.14.0.0 (unreleased)
 
+* [#1343](https://github.com/yesodweb/persistent/pull/1343)
+    * Implement Type Literal based field definitions
 * [#1387](https://github.com/yesodweb/persistent/pull/1387)
     * Better UX with `insert`. We now report a type error when you try to
       `insert` an `Entity` or a function, and we also forbid `insert`ing if the
@@ -47,7 +49,6 @@
     * Increasing test coverage for errors thrown when parsing entity definitions
 
 ## 2.13.3.4
-
 * [#1379](https://github.com/yesodweb/persistent/pull/1379)
     * `mkPersist` now generates code that compiles under `NoFieldSelectors` and `DuplicateRecordFields` even if field labels are not prefixed
 * [#1376](https://github.com/yesodweb/persistent/pull/1376)

persistent/Database/Persist/Quasi/Internal.hs

@@ -47,13 +47,14 @@ module Database.Persist.Quasi.Internal
     , ForeignFieldReference(..)
     , mkKeyConType
     , isHaskellUnboundField
+    , FieldTypeLit(..)
     ) where
 
 import Prelude hiding (lines)
 
 import Control.Applicative (Alternative((<|>)))
+import Data.Char (isDigit, isLower, isSpace, isUpper, toLower)
 import Control.Monad
-import Data.Char (isLower, isSpace, isUpper, toLower)
 import Data.List (find, foldl')
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NEL
@@ -64,8 +65,9 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Database.Persist.EntityDef.Internal
 import Database.Persist.Types
+import Database.Persist.Types.Base
 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 +97,59 @@ 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) = breakAtNextSpace t
+        lit <- FTLit . IntTypeLit <$> readMaybe (T.cons c a)
+        pure $ PSSuccess lit b
+
+    parseTypeCon c t = do
+        guard (isUpper c || c == '\'')
+        let (a, b) = breakAtNextSpace 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
-            -- _ ->
+
+breakAtNextSpace :: Text -> (Text, Text)
+breakAtNextSpace =
+    T.break isSpace
 
 parseFieldTypePiece :: Char -> Text -> FieldType
 parseFieldTypePiece fstChar rest =
@@ -1457,11 +1493,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
@@ -1486,3 +1518,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