diff --git a/persistent-qq/ChangeLog.md b/persistent-qq/ChangeLog.md index 3c35ddddd..15f5c5fb1 100644 --- a/persistent-qq/ChangeLog.md +++ b/persistent-qq/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-qq +## 2.12.0.7 +* [#1601](https://github.com/yesodweb/persistent/pull/1601) + * Adjust a test to avoid deprecated entity definition syntax + ## 2.12.0.6 * Fix test compilation by importing `Control.Monad` explicitly [#1487](https://github.com/yesodweb/persistent/pull/1487) diff --git a/persistent-qq/persistent-qq.cabal b/persistent-qq/persistent-qq.cabal index 5192bfe68..1cd3cccb7 100644 --- a/persistent-qq/persistent-qq.cabal +++ b/persistent-qq/persistent-qq.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: persistent-qq -version: 2.12.0.6 +version: 2.12.0.7 synopsis: Provides a quasi-quoter for raw SQL for persistent description: Please see README and API docs at . diff --git a/persistent-qq/test/PersistentTestModels.hs b/persistent-qq/test/PersistentTestModels.hs index 5b256cdfc..e3cc95142 100644 --- a/persistent-qq/test/PersistentTestModels.hs +++ b/persistent-qq/test/PersistentTestModels.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} - {-# OPTIONS_GHC -ddump-splices #-} module PersistentTestModels where @@ -29,16 +28,17 @@ import PersistTestPetCollarType import PersistTestPetType share - [ mkPersist sqlSettings { mpsGeneric = True } + [ mkPersist sqlSettings{mpsGeneric = True} , mkMigrate "testMigrate" - ] [persistUpperCase| + ] + [persistUpperCase| -- Dedented comment -- Header-level comment -- Indented comment Person json name Text - age Int "some ignored -- \" attribute" + age Int some="ignored -- \" attribute" color Text Maybe -- this is a comment sql=foobarbaz PersonNameKey name -- this is a comment sql=foobarbaz deriving Show Eq @@ -112,12 +112,14 @@ share |] -deriving instance Show (BackendKey backend) => Show (PetGeneric backend) -deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend) +deriving instance (Show (BackendKey backend)) => Show (PetGeneric backend) +deriving instance (Eq (BackendKey backend)) => Eq (PetGeneric backend) -share [ mkPersist sqlSettings { mpsPrefixFields = False, mpsGeneric = True } - , mkMigrate "noPrefixMigrate" - ] [persistLowerCase| +share + [ mkPersist sqlSettings{mpsPrefixFields = False, mpsGeneric = True} + , mkMigrate "noPrefixMigrate" + ] + [persistLowerCase| NoPrefix1 someFieldName Int NoPrefix2 @@ -129,23 +131,27 @@ NoPrefix2 deriving Show Eq |] -deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend) -deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend) +deriving instance (Show (BackendKey backend)) => Show (NoPrefix1Generic backend) +deriving instance (Eq (BackendKey backend)) => Eq (NoPrefix1Generic backend) -deriving instance Show (BackendKey backend) => Show (NoPrefix2Generic backend) -deriving instance Eq (BackendKey backend) => Eq (NoPrefix2Generic backend) +deriving instance (Show (BackendKey backend)) => Show (NoPrefix2Generic backend) +deriving instance (Eq (BackendKey backend)) => Eq (NoPrefix2Generic backend) -- | Reverses the order of the fields of an entity. Used to test -- @??@ placeholders of 'rawSql'. newtype ReverseFieldOrder a = RFO {unRFO :: a} deriving (Eq, Show) -instance ToJSON (Key (ReverseFieldOrder a)) where toJSON = error "ReverseFieldOrder" -instance FromJSON (Key (ReverseFieldOrder a)) where parseJSON = error "ReverseFieldOrder" + +instance ToJSON (Key (ReverseFieldOrder a)) where + toJSON = error "ReverseFieldOrder" +instance FromJSON (Key (ReverseFieldOrder a)) where + parseJSON = error "ReverseFieldOrder" instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where type PersistEntityBackend (ReverseFieldOrder a) = PersistEntityBackend a - newtype Key (ReverseFieldOrder a) = RFOKey { unRFOKey :: BackendKey SqlBackend } deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql) + newtype Key (ReverseFieldOrder a) = RFOKey {unRFOKey :: BackendKey SqlBackend} + deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql) keyFromValues = fmap RFOKey . fromPersistValue . head - keyToValues = (:[]) . toPersistValue . unRFOKey + keyToValues = (: []) . toPersistValue . unRFOKey entityDef = revFields . entityDef . unRfoProxy where @@ -158,7 +164,7 @@ instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where persistFieldDef = persistFieldDef . unEFRFO fromPersistValues = fmap RFO . fromPersistValues . reverse - newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a } + newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a} persistUniqueToFieldNames = NEL.reverse . persistUniqueToFieldNames . unURFO persistUniqueToValues = reverse . persistUniqueToValues . unURFO persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO @@ -170,11 +176,11 @@ cleanDB :: (MonadIO m, PersistQuery backend, PersistStoreWrite (BaseBackend backend)) => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter (PersonGeneric backend)]) - deleteWhere ([] :: [Filter (Person1Generic backend)]) - deleteWhere ([] :: [Filter (PetGeneric backend)]) - deleteWhere ([] :: [Filter (MaybeOwnedPetGeneric backend)]) - deleteWhere ([] :: [Filter (NeedsPetGeneric backend)]) - deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)]) - deleteWhere ([] :: [Filter (UserPTGeneric backend)]) - deleteWhere ([] :: [Filter (EmailPTGeneric backend)]) + deleteWhere ([] :: [Filter (PersonGeneric backend)]) + deleteWhere ([] :: [Filter (Person1Generic backend)]) + deleteWhere ([] :: [Filter (PetGeneric backend)]) + deleteWhere ([] :: [Filter (MaybeOwnedPetGeneric backend)]) + deleteWhere ([] :: [Filter (NeedsPetGeneric backend)]) + deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)]) + deleteWhere ([] :: [Filter (UserPTGeneric backend)]) + deleteWhere ([] :: [Filter (EmailPTGeneric backend)]) diff --git a/persistent-sqlite/test1.hs b/persistent-sqlite/test1.hs index c1e62e8f3..89e97e48f 100644 --- a/persistent-sqlite/test1.hs +++ b/persistent-sqlite/test1.hs @@ -1,3 +1,4 @@ +{- FOURMOLU_DISABLE -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,7 +9,7 @@ import Control.Monad.IO.Class mkPersist [$persist| Person sql=PersonTable name String update Eq Ne Desc In - age Int update "Asc" Lt "some ignored attribute" + age Int update Asc Lt someIgnoredAttribute color String null Eq Ne sql=mycolorfield NotIn Ge PersonNameKey name Pet diff --git a/persistent-test/ChangeLog.md b/persistent-test/ChangeLog.md index 5c71b2fcc..912b9f6e5 100644 --- a/persistent-test/ChangeLog.md +++ b/persistent-test/ChangeLog.md @@ -1,5 +1,9 @@ ## Unreleased changes +# 2.13.2.0 +* [#1601](https://github.com/yesodweb/persistent/pull/1601) + * Adjust test data to avoid deprecated entity definition syntax + ## 2.13.1.4 * Support `persistent-2.17` diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index c29277048..632aa4286 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -1,5 +1,5 @@ name: persistent-test -version: 2.13.1.4 +version: 2.13.2.0 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/persistent-test/src/PersistentTestModels.hs b/persistent-test/src/PersistentTestModels.hs index b6e0097db..ce2b6f2e3 100644 --- a/persistent-test/src/PersistentTestModels.hs +++ b/persistent-test/src/PersistentTestModels.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -- FIXME - +-- FIXME +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -ddump-splices #-} module PersistentTestModels where @@ -12,25 +12,27 @@ import Data.Aeson hiding (Key) import qualified Data.List.NonEmpty as NEL import Data.Proxy -import Test.QuickCheck +import Data.Text (append) import Database.Persist.Sql import Database.Persist.TH import Init -import PersistTestPetType import PersistTestPetCollarType -import Data.Text (append) +import PersistTestPetType +import Test.QuickCheck -- just need to ensure this compiles -import PersistentTestModelsImports() +import PersistentTestModelsImports () -share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate"] [persistUpperCase| +share + [mkPersist persistSettings{mpsGeneric = True}, mkMigrate "testMigrate"] + [persistUpperCase| -- Dedented comment -- Header-level comment -- Indented comment Person json name Text - age Int "some ignored -- \" attribute" + age Int some="ignored -- \" attribute" color Text Maybe -- this is a comment sql=foobarbaz PersonNameKey name -- this is a comment sql=foobarbaz deriving Show Eq @@ -125,20 +127,24 @@ share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate" |] -deriving instance Show (BackendKey backend) => Show (PetGeneric backend) -deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend) - -deriving instance Show (BackendKey backend) => Show (RelationshipGeneric backend) -deriving instance Eq (BackendKey backend) => Eq (RelationshipGeneric backend) - -share [mkPersist persistSettings { - mpsPrefixFields = False - , mpsFieldLabelModifier = \_ _ -> "" -- this field is ignored when mpsPrefixFields == False - , mpsConstraintLabelModifier = \_ _ -> "" -- this field is ignored when mpsPrefixFields == False - , mpsGeneric = True - } - , mkMigrate "noPrefixMigrate" - ] [persistLowerCase| +deriving instance (Show (BackendKey backend)) => Show (PetGeneric backend) +deriving instance (Eq (BackendKey backend)) => Eq (PetGeneric backend) + +deriving instance + (Show (BackendKey backend)) => Show (RelationshipGeneric backend) +deriving instance (Eq (BackendKey backend)) => Eq (RelationshipGeneric backend) + +share + [ mkPersist + persistSettings + { mpsPrefixFields = False + , mpsFieldLabelModifier = \_ _ -> "" -- this field is ignored when mpsPrefixFields == False + , mpsConstraintLabelModifier = \_ _ -> "" -- this field is ignored when mpsPrefixFields == False + , mpsGeneric = True + } + , mkMigrate "noPrefixMigrate" + ] + [persistLowerCase| NoPrefix1 someFieldName Int NoPrefix2 @@ -151,26 +157,29 @@ NoPrefix2 |] -deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend) -deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend) - -deriving instance Show (BackendKey backend) => Show (NoPrefix2Generic backend) -deriving instance Eq (BackendKey backend) => Eq (NoPrefix2Generic backend) - -share [mkPersist persistSettings { - mpsFieldLabelModifier = \entity field -> case entity of - "CustomPrefix1" -> append "_cp1" field - "CustomPrefix2" -> append "_cp2" field - _ -> error "should not be called" - , mpsConstraintLabelModifier = \entity field -> case entity of - "CustomPrefix1" -> append "CP1" field - "CustomPrefix2" -> append "CP2" field - "CustomPrefixSum" -> append "CP" field - _ -> error "should not be called" - , mpsGeneric = True - } - , mkMigrate "customPrefixMigrate" - ] [persistLowerCase| +deriving instance (Show (BackendKey backend)) => Show (NoPrefix1Generic backend) +deriving instance (Eq (BackendKey backend)) => Eq (NoPrefix1Generic backend) + +deriving instance (Show (BackendKey backend)) => Show (NoPrefix2Generic backend) +deriving instance (Eq (BackendKey backend)) => Eq (NoPrefix2Generic backend) + +share + [ mkPersist + persistSettings + { mpsFieldLabelModifier = \entity field -> case entity of + "CustomPrefix1" -> append "_cp1" field + "CustomPrefix2" -> append "_cp2" field + _ -> error "should not be called" + , mpsConstraintLabelModifier = \entity field -> case entity of + "CustomPrefix1" -> append "CP1" field + "CustomPrefix2" -> append "CP2" field + "CustomPrefixSum" -> append "CP" field + _ -> error "should not be called" + , mpsGeneric = True + } + , mkMigrate "customPrefixMigrate" + ] + [persistLowerCase| CustomPrefix1 customFieldName Int CustomPrefix2 @@ -182,15 +191,19 @@ CustomPrefix2 deriving Show Eq |] -deriving instance Show (BackendKey backend) => Show (CustomPrefix1Generic backend) -deriving instance Eq (BackendKey backend) => Eq (CustomPrefix1Generic backend) +deriving instance + (Show (BackendKey backend)) => Show (CustomPrefix1Generic backend) +deriving instance (Eq (BackendKey backend)) => Eq (CustomPrefix1Generic backend) -deriving instance Show (BackendKey backend) => Show (CustomPrefix2Generic backend) -deriving instance Eq (BackendKey backend) => Eq (CustomPrefix2Generic backend) +deriving instance + (Show (BackendKey backend)) => Show (CustomPrefix2Generic backend) +deriving instance (Eq (BackendKey backend)) => Eq (CustomPrefix2Generic backend) -share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = False } - , mkMigrate "treeMigrate" - ] [persistLowerCase| +share + [ mkPersist persistSettings{mpsPrefixFields = False, mpsGeneric = False} + , mkMigrate "treeMigrate" + ] + [persistLowerCase| Tree sql=trees name String @@ -202,14 +215,18 @@ Tree sql=trees -- | Reverses the order of the fields of an entity. Used to test -- @??@ placeholders of 'rawSql'. newtype ReverseFieldOrder a = RFO {unRFO :: a} deriving (Eq, Show) -instance ToJSON (Key (ReverseFieldOrder a)) where toJSON = error "ReverseFieldOrder" -instance FromJSON (Key (ReverseFieldOrder a)) where parseJSON = error "ReverseFieldOrder" + +instance ToJSON (Key (ReverseFieldOrder a)) where + toJSON = error "ReverseFieldOrder" +instance FromJSON (Key (ReverseFieldOrder a)) where + parseJSON = error "ReverseFieldOrder" instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where type PersistEntityBackend (ReverseFieldOrder a) = PersistEntityBackend a - newtype Key (ReverseFieldOrder a) = RFOKey { unRFOKey :: BackendKey SqlBackend } deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql) + newtype Key (ReverseFieldOrder a) = RFOKey {unRFOKey :: BackendKey SqlBackend} + deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql) keyFromValues = fmap RFOKey . fromPersistValue . head - keyToValues = (:[]) . toPersistValue . unRFOKey + keyToValues = (: []) . toPersistValue . unRFOKey entityDef = revFields . entityDef . unRfoProxy where @@ -222,7 +239,7 @@ instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where persistFieldDef = persistFieldDef . unEFRFO fromPersistValues = fmap RFO . fromPersistValues . reverse - newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a } + newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a} persistUniqueToFieldNames = NEL.reverse . persistUniqueToFieldNames . unURFO persistUniqueToValues = reverse . persistUniqueToValues . unURFO persistUniqueKeys = fmap URFO . reverse . persistUniqueKeys . unRFO @@ -234,13 +251,13 @@ cleanDB :: (MonadIO m, PersistQuery backend, PersistStoreWrite (BaseBackend backend)) => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter (PersonGeneric backend)]) - deleteWhere ([] :: [Filter (Person1Generic backend)]) - deleteWhere ([] :: [Filter (PetGeneric backend)]) - deleteWhere ([] :: [Filter (MaybeOwnedPetGeneric backend)]) - deleteWhere ([] :: [Filter (NeedsPetGeneric backend)]) - deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)]) - deleteWhere ([] :: [Filter (UserPTGeneric backend)]) - deleteWhere ([] :: [Filter (EmailPTGeneric backend)]) - deleteWhere ([] :: [Filter (UpsertGeneric backend)]) - deleteWhere ([] :: [Filter (UpsertByGeneric backend)]) + deleteWhere ([] :: [Filter (PersonGeneric backend)]) + deleteWhere ([] :: [Filter (Person1Generic backend)]) + deleteWhere ([] :: [Filter (PetGeneric backend)]) + deleteWhere ([] :: [Filter (MaybeOwnedPetGeneric backend)]) + deleteWhere ([] :: [Filter (NeedsPetGeneric backend)]) + deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)]) + deleteWhere ([] :: [Filter (UserPTGeneric backend)]) + deleteWhere ([] :: [Filter (EmailPTGeneric backend)]) + deleteWhere ([] :: [Filter (UpsertGeneric backend)]) + deleteWhere ([] :: [Filter (UpsertByGeneric backend)]) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index de47d1f4d..157c077a9 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for persistent +# 2.17.1.0 + +* [#1601](https://github.com/yesodweb/persistent/pull/1601) + * Fix parsing of quoted entity field attributes + * Add and enforce `psQuotedAttributeErrorLevel` to deprecate quoted entity field attributes + * Improve parsing of types and entity fields + # 2.17.0.0 * [#1595](https://github.com/yesodweb/persistent/pull/1595) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index 0206d7c46..52922a268 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -4,922 +4,923 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-| -This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities. - -The basic structure of the syntax looks like this: - -> TableName -> fieldName FieldType -> otherField String -> nullableField Int Maybe - -You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type. - -@persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL: - -> CREATE TABLE table_name ( -> id SERIAL PRIMARY KEY, -> field_name field_type NOT NULL, -> other_field varchar NOT NULL, -> nullable_field int NULL -> ); - -Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function. - -It generates a Haskell datatype with the following form: - -@ -data TableName = TableName - { tableNameFieldName :: FieldType - , tableNameOtherField :: String - , tableNameNullableField :: Maybe Int - } -@ - -As with the SQL generated, the specifics of this are customizable. -See the "Database.Persist.TH" module for details. - -= Deriving - -You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that. -Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses. - -> User -> name String -> age Int -> deriving Eq Show -> deriving Ord - -= Unique Keys - -You can define a uniqueness key on a table with the following format: - -> User -> name String -> age Int -> -> UniqueUserName name - -This will put a unique index on the @user@ table and the @name@ field. - -= Setting defaults - -You can use a @default=${sql expression}@ clause to set a default for a field. -The thing following the @=@ is interpreted as SQL that will be put directly into the table definition. - -@ -User - name Text - admin Bool default=false -@ - -This creates a SQL definition like this: - -> CREATE TABLE user ( -> id SERIAL PRIMARY KEY, -> name VARCHAR NOT NULL, -> admin BOOL DEFAULT=false -> ); - -A restriction here is that you still need to provide a value when performing an @insert@, because the generated Haskell type has the form: - -@ -data User = User - { userName :: Text - , userAdmin :: Bool - } -@ - -You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default. - -__Note__: Persistent determines whether or not to migrate a column's default -value by comparing the exact string found in your @models@ file with the one -returned by the database. If a database canonicalizes the SQL @FALSE@ from your -@models@ file to @false@ in the database, Persistent will think the default -value needs to be migrated and -. - -To workaround this, find the exact SQL your DBMS uses for the default value. For example, using postgres: - -@ -psql database_name # Open postgres - -\\d+ table_name -- describe the table schema -@ - -@ -... -created | timestamp without time zone | not null default now() -@ - -Then use the listed default value SQL inside your @models@ file. - -= Custom ID column - -If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field. -This @User@ has a @Text@ ID. - -> User -> Id Text -> name Text -> age Int - -If you do this, it's a good idea to set a default for the ID. -Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts. - -@ -'insertKey' (UserKey "Hello world!") (User "Bob" 32) -@ - -If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore. -So instead just use a default expression, like this: - -@ -User - Id Text default=generate_user_id() - name Text - age Int -@ - -= Custom Primary Keys - -Sometimes you don't want to have an ID column, and you want a different sort of primary key. -This is a table that stores unique email addresses, and the email is the primary key. -We store the first and second part (eg @first\@second@) separately. - -@ -Email - firstPart Text - secondPart Text - - Primary firstPart secondPart -@ - -This creates a table with the following form: - -@ -CREATE TABLE email ( - first_part varchar, - second_part varchar, - - PRIMARY KEY (first_part, second_part) -@ - -Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo. -As a key with multiple fields, it is also a "composite key." - -You can specify a @Primary@ key with a single field, too. - -= Overriding SQL - -You can use a @sql=custom@ annotation to provide some customization on the entity and field. -For example, you might prefer to name a table differently than what @persistent@ will do by default. -You may also prefer to name a field differently. - -@ -User sql=big_user_table - fullName String sql=name - age Int -@ - -This will alter the generated SQL to be: - -@ -CREATE TABEL big_user_table ( - id SERIAL PRIMARY KEY, - name VARCHAR, - age INT -); -@ - -= Customizing Types/Tables - -== JSON instances - -You can automatically get ToJSON and FromJSON instances for any entity by adding @json@ to the entity line: - -@ -Person json - name Text -@ -Requires @\{\-\# LANGUAGE FlexibleInstances \#\-\}@ - -Customizable by using mpsEntityJSON -* http://hackage.haskell.org/package/persistent-template/docs/Database-Persist-TH.html#v:EntityJSON -* http://hackage.haskell.org/package/persistent/docs/Database-Persist-Class.html#v:keyValueEntityToJSON - -== Changing table/collection name - -@ -Person sql=peoples - name Text -@ - -== Change table/collection key definition (field name and\/or type, persistent >= 2.1) - -@Id@ defines the column to use to define the key of the entity. -Without type, the default backend key type will be used. You can change its -database name using the @sql@ attributes : - -@ -Person - Id sql=my_id_name - phone Text -@ - -With a Haskell type, the corresponding type is used. Note that you'll need to -use @default=@ to tell it what to do on insertion. - -@ -Person - Id Day default=CURRENT_DATE - phone Text -@ - -@default=@ works for SQL databases, and is backend specific. -For MongoDB currently one always needs to create the key on the application -side and use @insertKey@. @insert@ will not work correctly. Sql backends can -also do this if default does not work. - -@sqltype@ can also be used to specify a different database type - -@ -Currency - Id String sqltype=varchar(3) sql=code -@ - -Composite key (using multiple columns) can also be defined using @Primary@. - -@sql=@ also works for setting the names of unique indexes. - -@ -Person - name Text - phone Text - UniquePersonPhone phone sql=UniqPerPhone -@ - -This makes a unique index requiring @phone@ to be unique across @Person@ rows. -Ordinarily Persistent will generate a snake-case index name from the -capitalized name provided such that @UniquePersonPhone@ becomes -@unique_person_phone@. However, we provided a @sql=@ so the index name in the -database will instead be @UniqPerPhone@. Keep in mind @sql=@ and @!@ attrs must -come after the list of fields in front of the index name in the quasi-quoter. - - - -= Customizing Fields - -== Nullable Fields - -As illustrated in the example at the beginning of this page, we are able to represent nullable -fields by including 'Maybe' at the end of the type declaration: - -> TableName -> fieldName FieldType -> otherField String -> nullableField Int Maybe - -Alternatively we can specify the keyword nullable: - -> TableName -> fieldName FieldType -> otherField String -> nullableField Int nullable - -However the difference here is in the first instance the Haskell type will be 'Maybe Int', -but in the second it will be 'Int'. Be aware that this will cause runtime errors if the -database returns @NULL@ and the @PersistField@ instance does not handle @PersistNull@. - -If you wish to define your Maybe types in a way that is similar to the actual Haskell -definition, you can define 'Maybe Int' like so: - -> TableName -> fieldName FieldType -> otherField String -> nullableField (Maybe Int) - -However, note, the field _must_ be enclosed in parenthesis. - -== @sqltype=@ - -By default, Persistent maps the Haskell types you specify in the Models DSL to -an appropriate SQL type in the database (refer to the section "Conversion table -(migrations)" for the default mappings). Using the -@sqltype=@ option, you can customize the SQL type Persistent uses for your -column. Use cases include: - -* Interacting with an existing database whose column types don't match Persistent's defaults. -* Taking advantage of a specific SQL type's features - * e.g. Using an equivalent type that has better space or performance characteristics - -To use this setting, add the @sqltype=@ option after declaring your field name and type: - -@ -User - username Text sqltype=varchar(255) -@ - -== Laziness - -By default the records created by persistent have strict fields. You can prefix -a field name with @~@ to make it lazy (or @!@ to make it strict). - -== Attributes - -The QuasiQuoter allows you to provide arbitrary attributes to an entity or field. -This can be used to extend the code in ways that the library hasn't anticipated. -If you use this feature, we'd definitely appreciate hearing about it and -potentially supporting your use case directly! - -@ -User !funny - field String !sad - good Dog !sogood -@ - -We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field. - -@ -userAttrs = do - let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User) - let userAttributes = 'entityAttrs' userDefinition - let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition) - print userAttributes --- ["funny"] - print fieldAttributes --- [["sad"],["sogood"]] -@ - -== @!no-migrate@ - -To prevent @migrateModels@ from generating _any_ migrations for an entity, add -the @!no-migrate@ attribute to it's definition: - -@ -User !no-migrate - field String - good Dog -@ - -== @MigrationOnly@ - -Introduced with @persistent-template@ 1.2.0. The purpose of this attribute is -to mark a field which will be entirely ignored by the normal processing, but -retained in the database definition for purposes of migration. This means, in -SQL, a column will not be flagged for removal by the migration scripts, even -though it is not used in your code. This is useful for phasing out usage of a -column before entirely removing it, or having columns which are needed by other -tools but not by Persistent. - -@ -Person - name Text - age Int - unusedField ByteString Maybe MigrationOnly -@ - -Note that you almost certainly want to either mark the field as @Maybe@ or -provide a default value, otherwise insertions will fail. - - -== @SafeToRemove@ - -This is intended to be used as part of a deprecation of a field, after -@MigrationOnly@ has been used usually. This works somewhat as a superset of the -functionality of @MigrationOnly@. In addition, the field will be removed from -the database if it is present. Note that this is a destructive change which you -are marking as safe. - -== Constraints - -Migration will remove any manual constraints from your tables. Exception: constraints whose names begin with the string @__manual_@ (which starts with two underscores) will be preserved. - - -= Foreign Keys - -If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly. - -@ -Person - name Text - -Dog - name Text - owner PersonId -@ - -This automatically creates a foreign key reference from @Dog@ to @Person@. -The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database. -If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred. - -== @constraint=@ - -You can use the @constraint=@ attribute to override the constraint name used in -migrations. This is useful particularly when the automatically generated -constraint names exceed database limits (e.g. MySQL does not allow constraint -names longer than 64 characters). - -@ -VeryLongTableName - name Text - -AnotherVeryLongTableName - veryLongTableNameId VeryLongTableNameId constraint=short_foreign_key -@ - -== OnUpdate and OnDelete - -These options affects how a referring record behaves when the target record is changed. -There are several options: - -* 'Restrict' - This is the default. It prevents the action from occurring. -* 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too. -* 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys. -* 'SetDefault' - This will set the column's value to the @default@ for the column, if specified. - -To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action. - -@ -Record - -- If the referred Foo is deleted or updated, then this record will - -- also be deleted or updated. - fooId FooId OnDeleteCascade OnUpdateCascade - - -- If the referred Bar is deleted, then we'll set the reference to - -- 'Nothing'. If the referred Bar is updated, then we'll cascade the - -- update. - barId BarId Maybe OnDeleteSetNull OnUpdateCascade - - -- If the referred Baz is deleted, then we set to the default ID. - bazId BazId OnDeleteSetDefault default=1 -@ - -Let's demonstrate this with a shopping cart example. - -@ -User - name Text - -Cart - user UserId Maybe - -CartItem - cartId CartId - itemId ItemId - -Item - name Text - price Int -@ - -Let's consider how we want to handle deletions and updates. -If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@. - -@ -Cart - user UserId Maybe OnDeleteCascade OnUpdateCascade -@ - -If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database. -If a @Cart@ is deleted, though, then we just want to delete the @CartItem@. - -@ -CartItem - cartId CartId OnDeleteCascade - itemId ItemId OnDeleteSetDefault default=1 -@ - -== @Foreign@ keyword - -The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword. - -A pseudo formal syntax for @Foreign@ is: - -@ -Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] - -columns := column0 [column1 column2 .. columnX] -references := References $(target-columns) -target-columns := target-column0 [target-column1 target-columns2 .. target-columnX] -@ - -Columns are the columns as defined on this entity. -@target-columns@ are the columns as defined on the target entity. - -Let's look at some examples. - -=== Composite Primary Key References - -The most common use for this is to refer to a composite primary key. -Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column. - -@ -Email - firstPart Text - secondPart Text - Primary firstPart secondPart - -User - name Text - emailFirstPart Text - emailSecondPart Text - - Foreign Email fk_user_email emailFirstPart emailSecondPart -@ - -If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key. -If we wanted to be fully redundant, we could specify the @References@ keyword. - -@ - Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart -@ - -We can specify delete/cascade behavior directly after the target table. - -@ - Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart -@ - -Now, if the email is deleted or updated, the user will be deleted or updated to match. - -=== Non-Primary Key References - -SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. -Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent. -To do this, we must use the @References@ keyword. - -@ -User - name Text - email Text - - UniqueEmail email - -Notification - content Text - sentTo Text - - Foreign User fk_noti_user sentTo References email -@ - -If the target uniqueness constraint has multiple columns, then you must specify them independently. - -@ -User - name Text - emailFirst Text - emailSecond Text - - UniqueEmail emailFirst emailSecond - -Notification - content Text - sentToFirst Text - sentToSecond Text - - Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond -@ - -= Documentation Comments - -The quasiquoter supports ordinary comments with @--@ and @#@. -Since @persistent-2.10.5.1@, it also supports documentation comments. -The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions: - -1. Only the @-- | @ form is allowed. -2. You must put a space before and after the @|@ pipe character. -3. The comment must be indented at the same level as the entity or field it documents. - -An example of the field documentation is: - -@ --- | I am a doc comment for a User. Users are important --- | to the application, and should be treasured. -User - -- | Users have names. Call them by names. - name String - -- | A user can be old, or young, and we care about - -- | this for some reason. - age Int -@ - -The documentation is present on the @entityComments@ field on the @EntityDef@ for the entity: - -@ ->>> let userDefinition = entityDef (Proxy :: Proxy User) ->>> entityComments userDefinition -"I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n" -@ - -Likewise, the field documentation is present in the @fieldComments@ field on the @FieldDef@ present in the @EntityDef@: - -@ ->>> let userFields = entityFields userDefinition ->>> let comments = map fieldComments userFields ->>> mapM_ putStrLn comments -"Users have names. Call them by names." -"A user can be old, or young, and we care about\nthis for some reason." -@ - -Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False). -@persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. - -= Sum types - -== Field level - -You'll frequently want to store an enum of values in your database. For -example, you might describe a @Person@'s employment status as being @Employed@, -@Unemployed@, or @Retired@. In Haskell this is represented with a sum type, and -Persistent provides a Template Haskell function to marshall these values to and -from the database: - -@ --- @Employment.hs -{-# LANGUAGE TemplateHaskell #-} -module Employment where - -import Database.Persist.TH -import Prelude - -data Employment = Employed | Unemployed | Retired - deriving (Show, Read, Eq) -derivePersistField "Employment" -@ - -@derivePersistField@ stores sum type values as strins in the database. While not as efficient as using integers, this approach simplifies adding and removing values from your enumeration. - -Due to the GHC Stage Restriction, the call to the Template Haskell function @derivePersistField@ must be in a separate module than where the generated code is used. - -Note: If you created a new module, make sure add it to the @exposed-modules@ section of your Cabal file. - -Use the module by importing it into your @Model.hs@ file: - -@ --- @Model.hs -import Employment -@ - -and use it in the @models@ DSL: - -@ -Person - employment Employment -@ - -You can export the Employment module from Import to use it across your app: - -@ --- @Import.hs -import Employment as Import -@ - -=== Entity-level - -NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints). - -The - -demonstrate their usage. Note the use of the sign @+@ in front of the entity -name. - -The schema in the test is reproduced here: - -@ -share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase| -Bicycle - brand T.Text -Car - make T.Text - model T.Text -+Vehicle - bicycle BicycleId - car CarId -|] -@ - -Let's check out the definition of the Haskell type @Vehicle@. -Using @ghci@, we can query for @:info Vehicle@: - ->>> :i Vehicle -type Vehicle = VehicleGeneric SqlBackend - -- Defined at .../Projects/persistent/persistent-test/src/SumTypeTest.hs:26:1 - ->>> :i VehicleGeneric -type role VehicleGeneric nominal -data VehicleGeneric backend - = VehicleBicycleSum (Key (BicycleGeneric backend)) - | VehicleCarSum (Key (CarGeneric backend)) - -- Defined at .../persistent/persistent-test/src/SumTypeTest.hs:26:1 --- lots of instances follow... - -A @VehicleGeneric@ has two constructors: - -- @VehicleBicycleSum@ with a @Key (BicycleGeneric backend)@ field -- @VehicleCarSum@ with a @Key (CarGeneric backend)@ field - -The @Bicycle@ and @Car@ are typical @persistent@ entities. - -This generates the following SQL migrations (formatted for readability): - -@ -CREATE TABLE "bicycle" ( - "id" INTEGER PRIMARY KEY, - "brand" VARCHAR NOT NULL -); - -CREATE TABLE "car"( - "id" INTEGER PRIMARY KEY, - "make" VARCHAR NOT NULL, - "model" VARCHAR NOT NULL -); - -CREATE TABLE "vehicle"( - "id" INTEGER PRIMARY KEY, - "bicycle" INTEGER NULL REFERENCES "bicycle", - "car" INTEGER NULL REFERENCES "car" -); -@ - -The @vehicle@ table contains a nullable foreign key reference to both the bicycle and the car tables. - -A SQL query that grabs all the vehicles from the database looks like this (note the @??@ is for the @persistent@ raw SQL query functions): - -@ -SELECT ??, ??, ?? -FROM vehicle -LEFT JOIN car - ON vehicle.car = car.id -LEFT JOIN bicycle - ON vehicle.bicycle = bicycle.id -@ - -If we use the above query with @rawSql@, we'd get the following result: - -@ -getVehicles - :: SqlPersistM - [ ( Entity Vehicle - , Maybe (Entity Bicycle) - , Maybe (Entity Car) - ) - ] -@ - -This result has some post-conditions that are not guaranteed by the types *or* the schema. -The constructor for @Entity Vehicle@ is going to determine which of the other members of the tuple is @Nothing@. -We can convert this to a friendlier domain model like this: - -@ -data Vehicle' - = Car' Text Text - | Bike Text - -check = do - result <- getVehicles - pure (map convert result) - -convert - :: (Entity Vehicle, Maybe (Entity Bicycle), Maybe (Entity Car)) - -> Vehicle' -convert (Entity _ (VehicycleBicycleSum _), Just (Entity _ (Bicycle brand)), _) = - Bike brand -convert (Entity _ (VehicycleCarSum _), _, Just (Entity _ (Car make model))) = - Car make model -convert _ = - error "The database preconditions have been violated!" -@ - -== Times with timezones - -Storing times with timezones in one type in databases is not possible, although -it seems that it should be possible (@timezone@ and @timezonetz@ in -PostgreSQL). That's why starting with persistent 2.0, all times will be mapped -to @UTCTime@. If you need to store timezone information along with times in a -database, store the timezone in a second field. Here are some links about the -topic with further information: - -* https://github.com/yesodweb/persistent/issues/290 -* https://groups.google.com/forum/#!msg/yesodweb/MIfcV2bwM80/8QLFpgp1LykJ -* http://stackoverflow.com/questions/14615271/postgres-timestamp/14616640#14616640 -* http://justatheory.com/computers/databases/postgresql/use-timestamptz.html -* https://github.com/lpsmith/postgresql-simple/issues/69 -* https://github.com/nikita-volkov/hasql-postgres/issues/1 - -= Conversion table (migrations) - -Here are the conversions between Haskell types and database types: - -+------------+----------------------+-------------------+---------------+----------------+ -| Haskell | PostgreSQL | MySQL | MongoDB | SQLite | -+============+======================+===================+===============+================+ -| Text | VARCHAR | TEXT | String | VARCHAR | -+------------+----------------------+-------------------+---------------+----------------+ -| ByteString | BYTEA | BLOB | BinData | BLOB | -+------------+----------------------+-------------------+---------------+----------------+ -| Int | INT8 | BIGINT(20) | NumberLong | INTEGER | -+------------+----------------------+-------------------+---------------+----------------+ -| Double | DOUBLE PRECISION | DOUBLE | Double | REAL | -+------------+----------------------+-------------------+---------------+----------------+ -| Rational | NUMERIC(22, 12) | DECIMAL(32,20) | *Unsupported* | NUMERIC(32,20)| -+------------+----------------------+-------------------+---------------+----------------+ -| Bool | BOOLEAN | TINYINT(1) | Boolean | BOOLEAN | -+------------+----------------------+-------------------+---------------+----------------+ -| Day | DATE | DATE | NumberLong | DATE | -+------------+----------------------+-------------------+---------------+----------------+ -| TimeOfDay | TIME | TIME\*\* | *Unsupported* | TIME | -+------------+----------------------+-------------------+---------------+----------------+ -| UTCTime\* | TIMESTAMP | DATETIME\*\* | Date | TIMESTAMP | -+------------+----------------------+-------------------+---------------+----------------+ - -Notes: - -\* Support for @ZonedTime@ was dropped in persistent 2.0. @UTCTime@ can be used -with @timestamp without timezone@ and @timestamp with timezone@ in PostgreSQL. -See also the section "Times with timezones". - -\*\* The default resolution for @TIME@ and @DATETIME@ in MySQL is one second. -As of MySQL version 5.6.4, and persistent-mysql-2.6.2, fractional seconds are -handled correctly if you declare an explicit precision by using @sqltype@. For -example, appending @sqltype=TIME(6)@ to a @TimeOfDay@ field definition will -give microsecond resolution. - -= Compatibility tables - -MySQL: - -+-------------------+-----------------------------------------------------------------------+ -|Haskell type | Compatible MySQL types | -+===================+=======================================================================+ -| Bool | Tiny | -+-------------------+-----------------------------------------------------------------------+ -| Int8 | Tiny | -+-------------------+-----------------------------------------------------------------------+ -| Int16 | Tiny,Short | -+-------------------+-----------------------------------------------------------------------+ -| Int32 | Tiny,Short,Int24,Long | -+-------------------+-----------------------------------------------------------------------+ -| Int | Tiny,Short,Int24,Long,LongLong\* | -+-------------------+-----------------------------------------------------------------------+ -| Int64 | Tiny,Short,Int24,Long,LongLong | -+-------------------+-----------------------------------------------------------------------+ -| Integer | Tiny,Short,Int24,Long,LongLong | -+-------------------+-----------------------------------------------------------------------+ -| Word8 | Tiny | -+-------------------+-----------------------------------------------------------------------+ -| Word16 | Tiny,Short | -+-------------------+-----------------------------------------------------------------------+ -| Word32 | Tiny,Short,Int24,Long | -+-------------------+-----------------------------------------------------------------------+ -| Word64 | Tiny,Short,Int24,Long,LongLong | -| Double | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long | -+-------------------+-----------------------------------------------------------------------+ -| Ratio Integer | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long,LongLong | -+-------------------+-----------------------------------------------------------------------+ -| ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | -+-------------------+-----------------------------------------------------------------------+ -| Lazy.ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | -+-------------------+-----------------------------------------------------------------------+ -| Encoding.Text\*\* | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | -+-------------------+-----------------------------------------------------------------------+ -| Lazy.Text | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | -+-------------------+-----------------------------------------------------------------------+ -| [Char]/String | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | -+-------------------+-----------------------------------------------------------------------+ -| UTCTime | DateTime,Timestamp | -+-------------------+-----------------------------------------------------------------------+ -| Day | Year,Date,NewDate | -+-------------------+-----------------------------------------------------------------------+ -| TimeOfDay | Time | -+-------------------+-----------------------------------------------------------------------+ - -\* When @Word@ size is 64bit - -\*\* Utf8 only - -Unsupported types: - -+--------------------------------------------------------------------+ -| Not currently supported | -+====================================================================+ -| Word | -+--------------------------------------------------------------------+ -| Float | -+--------------------------------------------------------------------+ -| Scientific | -+--------------------------------------------------------------------+ - -See . --} +-- | +-- This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities. +-- +-- The basic structure of the syntax looks like this: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField Int Maybe +-- +-- You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type. +-- +-- @persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL: +-- +-- > CREATE TABLE table_name ( +-- > id SERIAL PRIMARY KEY, +-- > field_name field_type NOT NULL, +-- > other_field varchar NOT NULL, +-- > nullable_field int NULL +-- > ); +-- +-- Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function. +-- +-- It generates a Haskell datatype with the following form: +-- +-- @ +-- data TableName = TableName +-- { tableNameFieldName :: FieldType +-- , tableNameOtherField :: String +-- , tableNameNullableField :: Maybe Int +-- } +-- @ +-- +-- As with the SQL generated, the specifics of this are customizable. +-- See the "Database.Persist.TH" module for details. +-- +-- = Deriving +-- +-- You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that. +-- Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses. +-- +-- > User +-- > name String +-- > age Int +-- > deriving Eq Show +-- > deriving Ord +-- +-- = Unique Keys +-- +-- You can define a uniqueness key on a table with the following format: +-- +-- > User +-- > name String +-- > age Int +-- > +-- > UniqueUserName name +-- +-- This will put a unique index on the @user@ table and the @name@ field. +-- +-- = Setting defaults +-- +-- You can use a @default=${sql expression}@ clause to set a default for a field. +-- The thing following the @=@ is interpreted as SQL that will be put directly into the table definition. +-- +-- @ +-- User +-- name Text +-- admin Bool default=false +-- @ +-- +-- This creates a SQL definition like this: +-- +-- > CREATE TABLE user ( +-- > id SERIAL PRIMARY KEY, +-- > name VARCHAR NOT NULL, +-- > admin BOOL DEFAULT=false +-- > ); +-- +-- A restriction here is that you still need to provide a value when performing an @insert@, because the generated Haskell type has the form: +-- +-- @ +-- data User = User +-- { userName :: Text +-- , userAdmin :: Bool +-- } +-- @ +-- +-- You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default. +-- +-- __Note__: Persistent determines whether or not to migrate a column's default +-- value by comparing the exact string found in your @models@ file with the one +-- returned by the database. If a database canonicalizes the SQL @FALSE@ from your +-- @models@ file to @false@ in the database, Persistent will think the default +-- value needs to be migrated and +-- . +-- +-- To workaround this, find the exact SQL your DBMS uses for the default value. For example, using postgres: +-- +-- @ +-- psql database_name # Open postgres +-- +-- \\d+ table_name -- describe the table schema +-- @ +-- +-- @ +-- ... +-- created | timestamp without time zone | not null default now() +-- @ +-- +-- Then use the listed default value SQL inside your @models@ file. +-- +-- = Custom ID column +-- +-- If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field. +-- This @User@ has a @Text@ ID. +-- +-- > User +-- > Id Text +-- > name Text +-- > age Int +-- +-- If you do this, it's a good idea to set a default for the ID. +-- Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts. +-- +-- @ +-- 'insertKey' (UserKey "Hello world!") (User "Bob" 32) +-- @ +-- +-- If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore. +-- So instead just use a default expression, like this: +-- +-- @ +-- User +-- Id Text default=generate_user_id() +-- name Text +-- age Int +-- @ +-- +-- = Custom Primary Keys +-- +-- Sometimes you don't want to have an ID column, and you want a different sort of primary key. +-- This is a table that stores unique email addresses, and the email is the primary key. +-- We store the first and second part (eg @first\@second@) separately. +-- +-- @ +-- Email +-- firstPart Text +-- secondPart Text +-- +-- Primary firstPart secondPart +-- @ +-- +-- This creates a table with the following form: +-- +-- @ +-- CREATE TABLE email ( +-- first_part varchar, +-- second_part varchar, +-- +-- PRIMARY KEY (first_part, second_part) +-- @ +-- +-- Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo. +-- As a key with multiple fields, it is also a "composite key." +-- +-- You can specify a @Primary@ key with a single field, too. +-- +-- = Overriding SQL +-- +-- You can use a @sql=custom@ annotation to provide some customization on the entity and field. +-- For example, you might prefer to name a table differently than what @persistent@ will do by default. +-- You may also prefer to name a field differently. +-- +-- @ +-- User sql=big_user_table +-- fullName String sql=name +-- age Int +-- @ +-- +-- This will alter the generated SQL to be: +-- +-- @ +-- CREATE TABLE big_user_table ( +-- id SERIAL PRIMARY KEY, +-- name VARCHAR, +-- age INT +-- ); +-- @ +-- +-- = Customizing Types/Tables +-- +-- == JSON instances +-- +-- You can automatically get ToJSON and FromJSON instances for any entity by adding @json@ to the entity line: +-- +-- @ +-- Person json +-- name Text +-- @ +-- Requires @\{\-\# LANGUAGE FlexibleInstances \#\-\}@ +-- +-- Customizable by using mpsEntityJSON +-- * http://hackage.haskell.org/package/persistent-template/docs/Database-Persist-TH.html#v:EntityJSON +-- * http://hackage.haskell.org/package/persistent/docs/Database-Persist-Class.html#v:keyValueEntityToJSON +-- +-- == Changing table/collection name +-- +-- @ +-- Person sql=peoples +-- name Text +-- @ +-- +-- == Change table/collection key definition (field name and\/or type, persistent >= 2.1) +-- +-- @Id@ defines the column to use to define the key of the entity. +-- Without type, the default backend key type will be used. You can change its +-- database name using the @sql@ attributes : +-- +-- @ +-- Person +-- Id sql=my_id_name +-- phone Text +-- @ +-- +-- With a Haskell type, the corresponding type is used. Note that you'll need to +-- use @default=@ to tell it what to do on insertion. +-- +-- @ +-- Person +-- Id Day default=CURRENT_DATE +-- phone Text +-- @ +-- +-- @default=@ works for SQL databases, and is backend specific. +-- For MongoDB currently one always needs to create the key on the application +-- side and use @insertKey@. @insert@ will not work correctly. Sql backends can +-- also do this if default does not work. +-- +-- @sqltype@ can also be used to specify a different database type +-- +-- @ +-- Currency +-- Id String sqltype=varchar(3) sql=code +-- @ +-- +-- Composite key (using multiple columns) can also be defined using @Primary@. +-- +-- @sql=@ also works for setting the names of unique indexes. +-- +-- @ +-- Person +-- name Text +-- phone Text +-- UniquePersonPhone phone sql=UniqPerPhone +-- @ +-- +-- This makes a unique index requiring @phone@ to be unique across @Person@ rows. +-- Ordinarily Persistent will generate a snake-case index name from the +-- capitalized name provided such that @UniquePersonPhone@ becomes +-- @unique_person_phone@. However, we provided a @sql=@ so the index name in the +-- database will instead be @UniqPerPhone@. Keep in mind @sql=@ and @!@ attrs must +-- come after the list of fields in front of the index name in the quasi-quoter. +-- +-- +-- +-- = Customizing Fields +-- +-- == Nullable Fields +-- +-- As illustrated in the example at the beginning of this page, we are able to represent nullable +-- fields by including 'Maybe' at the end of the type declaration: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField Int Maybe +-- +-- Alternatively we can specify the keyword nullable: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField Int nullable +-- +-- However the difference here is in the first instance the Haskell type will be 'Maybe Int', +-- but in the second it will be 'Int'. Be aware that this will cause runtime errors if the +-- database returns @NULL@ and the @PersistField@ instance does not handle @PersistNull@. +-- +-- If you wish to define your Maybe types in a way that is similar to the actual Haskell +-- definition, you can define 'Maybe Int' like so: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField (Maybe Int) +-- +-- However, note, the field _must_ be enclosed in parenthesis. +-- +-- == @sqltype=@ +-- +-- By default, Persistent maps the Haskell types you specify in the Models DSL to +-- an appropriate SQL type in the database (refer to the section "Conversion table +-- (migrations)" for the default mappings). Using the +-- @sqltype=@ option, you can customize the SQL type Persistent uses for your +-- column. Use cases include: +-- +-- * Interacting with an existing database whose column types don't match Persistent's defaults. +-- * Taking advantage of a specific SQL type's features +-- * e.g. Using an equivalent type that has better space or performance characteristics +-- +-- To use this setting, add the @sqltype=@ option after declaring your field name and type: +-- +-- @ +-- User +-- username Text sqltype=varchar(255) +-- @ +-- +-- == Laziness +-- +-- By default the records created by persistent have strict fields. You can prefix +-- a field name with @~@ to make it lazy (or @!@ to make it strict). +-- +-- == Attributes +-- +-- The QuasiQuoter allows you to provide arbitrary attributes to an entity or field. +-- This can be used to extend the code in ways that the library hasn't anticipated. +-- If you use this feature, we'd definitely appreciate hearing about it and +-- potentially supporting your use case directly! +-- +-- @ +-- User !funny +-- field String !sad +-- good Dog !sogood +-- @ +-- +-- We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field. +-- +-- @ +-- userAttrs = do +-- let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User) +-- let userAttributes = 'entityAttrs' userDefinition +-- let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition) +-- print userAttributes +-- -- ["funny"] +-- print fieldAttributes +-- -- [["sad"],["sogood"]] +-- @ +-- +-- == @!no-migrate@ +-- +-- To prevent @migrateModels@ from generating _any_ migrations for an entity, add +-- the @!no-migrate@ attribute to it's definition: +-- +-- @ +-- User !no-migrate +-- field String +-- good Dog +-- @ +-- +-- == @MigrationOnly@ +-- +-- Introduced with @persistent-template@ 1.2.0. The purpose of this attribute is +-- to mark a field which will be entirely ignored by the normal processing, but +-- retained in the database definition for purposes of migration. This means, in +-- SQL, a column will not be flagged for removal by the migration scripts, even +-- though it is not used in your code. This is useful for phasing out usage of a +-- column before entirely removing it, or having columns which are needed by other +-- tools but not by Persistent. +-- +-- @ +-- Person +-- name Text +-- age Int +-- unusedField ByteString Maybe MigrationOnly +-- @ +-- +-- Note that you almost certainly want to either mark the field as @Maybe@ or +-- provide a default value, otherwise insertions will fail. +-- +-- +-- == @SafeToRemove@ +-- +-- This is intended to be used as part of a deprecation of a field, after +-- @MigrationOnly@ has been used usually. This works somewhat as a superset of the +-- functionality of @MigrationOnly@. In addition, the field will be removed from +-- the database if it is present. Note that this is a destructive change which you +-- are marking as safe. +-- +-- == Constraints +-- +-- Migration will remove any manual constraints from your tables. Exception: constraints whose names begin with the string @__manual_@ (which starts with two underscores) will be preserved. +-- +-- +-- = Foreign Keys +-- +-- If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly. +-- +-- @ +-- Person +-- name Text +-- +-- Dog +-- name Text +-- owner PersonId +-- @ +-- +-- This automatically creates a foreign key reference from @Dog@ to @Person@. +-- The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database. +-- If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred. +-- +-- == @constraint=@ +-- +-- You can use the @constraint=@ attribute to override the constraint name used in +-- migrations. This is useful particularly when the automatically generated +-- constraint names exceed database limits (e.g. MySQL does not allow constraint +-- names longer than 64 characters). +-- +-- @ +-- VeryLongTableName +-- name Text +-- +-- AnotherVeryLongTableName +-- veryLongTableNameId VeryLongTableNameId constraint=short_foreign_key +-- @ +-- +-- == OnUpdate and OnDelete +-- +-- These options affects how a referring record behaves when the target record is changed. +-- There are several options: +-- +-- * 'Restrict' - This is the default. It prevents the action from occurring. +-- * 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too. +-- * 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys. +-- * 'SetDefault' - This will set the column's value to the @default@ for the column, if specified. +-- +-- To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action. +-- +-- @ +-- Record +-- -- If the referred Foo is deleted or updated, then this record will +-- -- also be deleted or updated. +-- fooId FooId OnDeleteCascade OnUpdateCascade +-- +-- -- If the referred Bar is deleted, then we'll set the reference to +-- -- 'Nothing'. If the referred Bar is updated, then we'll cascade the +-- -- update. +-- barId BarId Maybe OnDeleteSetNull OnUpdateCascade +-- +-- -- If the referred Baz is deleted, then we set to the default ID. +-- bazId BazId OnDeleteSetDefault default=1 +-- @ +-- +-- Let's demonstrate this with a shopping cart example. +-- +-- @ +-- User +-- name Text +-- +-- Cart +-- user UserId Maybe +-- +-- CartItem +-- cartId CartId +-- itemId ItemId +-- +-- Item +-- name Text +-- price Int +-- @ +-- +-- Let's consider how we want to handle deletions and updates. +-- If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@. +-- +-- @ +-- Cart +-- user UserId Maybe OnDeleteCascade OnUpdateCascade +-- @ +-- +-- If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database. +-- If a @Cart@ is deleted, though, then we just want to delete the @CartItem@. +-- +-- @ +-- CartItem +-- cartId CartId OnDeleteCascade +-- itemId ItemId OnDeleteSetDefault default=1 +-- @ +-- +-- == @Foreign@ keyword +-- +-- The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword. +-- +-- A pseudo formal syntax for @Foreign@ is: +-- +-- @ +-- Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] +-- +-- columns := column0 [column1 column2 .. columnX] +-- references := References $(target-columns) +-- target-columns := target-column0 [target-column1 target-columns2 .. target-columnX] +-- @ +-- +-- Columns are the columns as defined on this entity. +-- @target-columns@ are the columns as defined on the target entity. +-- +-- Let's look at some examples. +-- +-- === Composite Primary Key References +-- +-- The most common use for this is to refer to a composite primary key. +-- Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column. +-- +-- @ +-- Email +-- firstPart Text +-- secondPart Text +-- Primary firstPart secondPart +-- +-- User +-- name Text +-- emailFirstPart Text +-- emailSecondPart Text +-- +-- Foreign Email fk_user_email emailFirstPart emailSecondPart +-- @ +-- +-- If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key. +-- If we wanted to be fully redundant, we could specify the @References@ keyword. +-- +-- @ +-- Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart +-- @ +-- +-- We can specify delete/cascade behavior directly after the target table. +-- +-- @ +-- Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart +-- @ +-- +-- Now, if the email is deleted or updated, the user will be deleted or updated to match. +-- +-- === Non-Primary Key References +-- +-- SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. +-- Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent. +-- To do this, we must use the @References@ keyword. +-- +-- @ +-- User +-- name Text +-- email Text +-- +-- UniqueEmail email +-- +-- Notification +-- content Text +-- sentTo Text +-- +-- Foreign User fk_noti_user sentTo References email +-- @ +-- +-- If the target uniqueness constraint has multiple columns, then you must specify them independently. +-- +-- @ +-- User +-- name Text +-- emailFirst Text +-- emailSecond Text +-- +-- UniqueEmail emailFirst emailSecond +-- +-- Notification +-- content Text +-- sentToFirst Text +-- sentToSecond Text +-- +-- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond +-- @ +-- +-- = Documentation Comments +-- +-- The quasiquoter supports ordinary comments with @--@ and @#@. +-- Since @persistent-2.10.5.1@, it also supports documentation comments. +-- The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions: +-- +-- 1. Only the @-- | @ form is allowed. +-- 2. You must put a space before and after the @|@ pipe character. +-- 3. The comment must be indented at the same level as the entity or field it documents. +-- +-- An example of the field documentation is: +-- +-- @ +-- -- | I am a doc comment for a User. Users are important +-- -- | to the application, and should be treasured. +-- User +-- -- | Users have names. Call them by names. +-- name String +-- -- | A user can be old, or young, and we care about +-- -- | this for some reason. +-- age Int +-- @ +-- +-- The documentation is present on the @entityComments@ field on the @EntityDef@ for the entity: +-- +-- @ +-- >>> let userDefinition = entityDef (Proxy :: Proxy User) +-- >>> entityComments userDefinition +-- "I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n" +-- @ +-- +-- Likewise, the field documentation is present in the @fieldComments@ field on the @FieldDef@ present in the @EntityDef@: +-- +-- @ +-- >>> let userFields = entityFields userDefinition +-- >>> let comments = map fieldComments userFields +-- >>> mapM_ putStrLn comments +-- "Users have names. Call them by names." +-- "A user can be old, or young, and we care about\nthis for some reason." +-- @ +-- +-- Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False). +-- @persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. +-- +-- = Sum types +-- +-- == Field level +-- +-- You'll frequently want to store an enum of values in your database. For +-- example, you might describe a @Person@'s employment status as being @Employed@, +-- @Unemployed@, or @Retired@. In Haskell this is represented with a sum type, and +-- Persistent provides a Template Haskell function to marshall these values to and +-- from the database: +-- +-- @ +-- -- @Employment.hs +-- {-# LANGUAGE TemplateHaskell #-} +-- module Employment where +-- +-- import Database.Persist.TH +-- import Prelude +-- +-- data Employment = Employed | Unemployed | Retired +-- deriving (Show, Read, Eq) +-- derivePersistField "Employment" +-- @ +-- +-- @derivePersistField@ stores sum type values as strins in the database. While not as efficient as using integers, this approach simplifies adding and removing values from your enumeration. +-- +-- Due to the GHC Stage Restriction, the call to the Template Haskell function @derivePersistField@ must be in a separate module than where the generated code is used. +-- +-- Note: If you created a new module, make sure add it to the @exposed-modules@ section of your Cabal file. +-- +-- Use the module by importing it into your @Model.hs@ file: +-- +-- @ +-- -- @Model.hs +-- import Employment +-- @ +-- +-- and use it in the @models@ DSL: +-- +-- @ +-- Person +-- employment Employment +-- @ +-- +-- You can export the Employment module from Import to use it across your app: +-- +-- @ +-- -- @Import.hs +-- import Employment as Import +-- @ +-- +-- === Entity-level +-- +-- NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints). +-- +-- The +-- +-- demonstrate their usage. Note the use of the sign @+@ in front of the entity +-- name. +-- +-- The schema in the test is reproduced here: +-- +-- @ +-- share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase| +-- Bicycle +-- brand T.Text +-- Car +-- make T.Text +-- model T.Text +-- +Vehicle +-- bicycle BicycleId +-- car CarId +-- |] +-- @ +-- +-- Let's check out the definition of the Haskell type @Vehicle@. +-- Using @ghci@, we can query for @:info Vehicle@: +-- +-- >>> :i Vehicle +-- type Vehicle = VehicleGeneric SqlBackend +-- -- Defined at .../Projects/persistent/persistent-test/src/SumTypeTest.hs:26:1 +-- +-- >>> :i VehicleGeneric +-- type role VehicleGeneric nominal +-- data VehicleGeneric backend +-- = VehicleBicycleSum (Key (BicycleGeneric backend)) +-- | VehicleCarSum (Key (CarGeneric backend)) +-- -- Defined at .../persistent/persistent-test/src/SumTypeTest.hs:26:1 +-- -- lots of instances follow... +-- +-- A @VehicleGeneric@ has two constructors: +-- +-- - @VehicleBicycleSum@ with a @Key (BicycleGeneric backend)@ field +-- - @VehicleCarSum@ with a @Key (CarGeneric backend)@ field +-- +-- The @Bicycle@ and @Car@ are typical @persistent@ entities. +-- +-- This generates the following SQL migrations (formatted for readability): +-- +-- @ +-- CREATE TABLE "bicycle" ( +-- "id" INTEGER PRIMARY KEY, +-- "brand" VARCHAR NOT NULL +-- ); +-- +-- CREATE TABLE "car"( +-- "id" INTEGER PRIMARY KEY, +-- "make" VARCHAR NOT NULL, +-- "model" VARCHAR NOT NULL +-- ); +-- +-- CREATE TABLE "vehicle"( +-- "id" INTEGER PRIMARY KEY, +-- "bicycle" INTEGER NULL REFERENCES "bicycle", +-- "car" INTEGER NULL REFERENCES "car" +-- ); +-- @ +-- +-- The @vehicle@ table contains a nullable foreign key reference to both the bicycle and the car tables. +-- +-- A SQL query that grabs all the vehicles from the database looks like this (note the @??@ is for the @persistent@ raw SQL query functions): +-- +-- @ +-- SELECT ??, ??, ?? +-- FROM vehicle +-- LEFT JOIN car +-- ON vehicle.car = car.id +-- LEFT JOIN bicycle +-- ON vehicle.bicycle = bicycle.id +-- @ +-- +-- If we use the above query with @rawSql@, we'd get the following result: +-- +-- @ +-- getVehicles +-- :: SqlPersistM +-- [ ( Entity Vehicle +-- , Maybe (Entity Bicycle) +-- , Maybe (Entity Car) +-- ) +-- ] +-- @ +-- +-- This result has some post-conditions that are not guaranteed by the types *or* the schema. +-- The constructor for @Entity Vehicle@ is going to determine which of the other members of the tuple is @Nothing@. +-- We can convert this to a friendlier domain model like this: +-- +-- @ +-- data Vehicle' +-- = Car' Text Text +-- | Bike Text +-- +-- check = do +-- result <- getVehicles +-- pure (map convert result) +-- +-- convert +-- :: (Entity Vehicle, Maybe (Entity Bicycle), Maybe (Entity Car)) +-- -> Vehicle' +-- convert (Entity _ (VehicleBicycleSum _), Just (Entity _ (Bicycle brand)), _) = +-- Bike brand +-- convert (Entity _ (VehicleCarSum _), _, Just (Entity _ (Car make model))) = +-- Car make model +-- convert _ = +-- error "The database preconditions have been violated!" +-- @ +-- +-- == Times with timezones +-- +-- Storing times with timezones in one type in databases is not possible, although +-- it seems that it should be possible (@timezone@ and @timezonetz@ in +-- PostgreSQL). That's why starting with persistent 2.0, all times will be mapped +-- to @UTCTime@. If you need to store timezone information along with times in a +-- database, store the timezone in a second field. Here are some links about the +-- topic with further information: +-- +-- * https://github.com/yesodweb/persistent/issues/290 +-- * https://groups.google.com/forum/#!msg/yesodweb/MIfcV2bwM80/8QLFpgp1LykJ +-- * http://stackoverflow.com/questions/14615271/postgres-timestamp/14616640#14616640 +-- * http://justatheory.com/computers/databases/postgresql/use-timestamptz.html +-- * https://github.com/lpsmith/postgresql-simple/issues/69 +-- * https://github.com/nikita-volkov/hasql-postgres/issues/1 +-- +-- = Conversion table (migrations) +-- +-- Here are the conversions between Haskell types and database types: +-- +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Haskell | PostgreSQL | MySQL | MongoDB | SQLite | +-- +============+======================+===================+===============+================+ +-- | Text | VARCHAR | TEXT | String | VARCHAR | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | ByteString | BYTEA | BLOB | BinData | BLOB | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Int | INT8 | BIGINT(20) | NumberLong | INTEGER | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Double | DOUBLE PRECISION | DOUBLE | Double | REAL | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Rational | NUMERIC(22, 12) | DECIMAL(32,20) | *Unsupported* | NUMERIC(32,20)| +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Bool | BOOLEAN | TINYINT(1) | Boolean | BOOLEAN | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Day | DATE | DATE | NumberLong | DATE | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | TimeOfDay | TIME | TIME\*\* | *Unsupported* | TIME | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | UTCTime\* | TIMESTAMP | DATETIME\*\* | Date | TIMESTAMP | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- +-- Notes: +-- +-- \* Support for @ZonedTime@ was dropped in persistent 2.0. @UTCTime@ can be used +-- with @timestamp without timezone@ and @timestamp with timezone@ in PostgreSQL. +-- See also the section "Times with timezones". +-- +-- \*\* The default resolution for @TIME@ and @DATETIME@ in MySQL is one second. +-- As of MySQL version 5.6.4, and persistent-mysql-2.6.2, fractional seconds are +-- handled correctly if you declare an explicit precision by using @sqltype@. For +-- example, appending @sqltype=TIME(6)@ to a @TimeOfDay@ field definition will +-- give microsecond resolution. +-- +-- = Compatibility tables +-- +-- MySQL: +-- +-- +-------------------+-----------------------------------------------------------------------+ +-- |Haskell type | Compatible MySQL types | +-- +===================+=======================================================================+ +-- | Bool | Tiny | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int8 | Tiny | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int16 | Tiny,Short | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int32 | Tiny,Short,Int24,Long | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int | Tiny,Short,Int24,Long,LongLong\* | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int64 | Tiny,Short,Int24,Long,LongLong | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Integer | Tiny,Short,Int24,Long,LongLong | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word8 | Tiny | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word16 | Tiny,Short | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word32 | Tiny,Short,Int24,Long | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word64 | Tiny,Short,Int24,Long,LongLong | +-- | Double | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Ratio Integer | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long,LongLong | +-- +-------------------+-----------------------------------------------------------------------+ +-- | ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Lazy.ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Encoding.Text\*\* | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Lazy.Text | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | [Char]/String | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | UTCTime | DateTime,Timestamp | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Day | Year,Date,NewDate | +-- +-------------------+-----------------------------------------------------------------------+ +-- | TimeOfDay | Time | +-- +-------------------+-----------------------------------------------------------------------+ +-- +-- \* When @Word@ size is 64bit +-- +-- \*\* Utf8 only +-- +-- Unsupported types: +-- +-- +--------------------------------------------------------------------+ +-- | Not currently supported | +-- +====================================================================+ +-- | Word | +-- +--------------------------------------------------------------------+ +-- | Float | +-- +--------------------------------------------------------------------+ +-- | Scientific | +-- +--------------------------------------------------------------------+ +-- +-- See . module Database.Persist.Quasi ( parse - -- * 'PersistSettings' + + -- * 'PersistSettings' , PersistSettings , upperCaseSettings , lowerCaseSettings - -- ** Getters and Setters + + -- ** Getters and Setters , getPsToDBName , setPsToDBName , setPsToFKName @@ -931,7 +932,9 @@ module Database.Persist.Quasi , setPsIdName , getPsTabErrorLevel , setPsTabErrorLevel + , getPsQuotedArgumentErrorLevel + , setPsQuotedArgumentErrorLevel ) where -import Database.Persist.Quasi.PersistSettings import Database.Persist.Quasi.Internal +import Database.Persist.Quasi.PersistSettings diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index be60368af..8641d8aa6 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -16,7 +16,7 @@ module Database.Persist.Quasi.Internal , PersistSettings (..) , upperCaseSettings , lowerCaseSettings - , Token (..) + , Attribute (..) , SourceLoc (..) , sourceLocFromTHLoc , parseFieldType @@ -61,13 +61,14 @@ import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T import Database.Persist.EntityDef.Internal -import Database.Persist.Quasi.PersistSettings -import Database.Persist.Quasi.PersistSettings.Internal ( psToFKName - , psToDBName - , psIdName - , psStrictFields - ) import Database.Persist.Quasi.Internal.ModelParser +import Database.Persist.Quasi.PersistSettings +import Database.Persist.Quasi.PersistSettings.Internal + ( psIdName + , psStrictFields + , psToDBName + , psToFKName + ) import Database.Persist.Types import Database.Persist.Types.Base import Language.Haskell.TH.Syntax (Lift, Loc (..)) @@ -185,14 +186,14 @@ sourceLocFromTHLoc Loc{loc_filename = filename, loc_start = start} = -- | Parses a quasi-quoted syntax into a list of entity definitions. parse - :: PersistSettings - -> [(Maybe SourceLoc, Text)] - -> CumulativeParseResult [UnboundEntityDef] + :: PersistSettings + -> [(Maybe SourceLoc, Text)] + -> CumulativeParseResult [UnboundEntityDef] parse ps chunks = toCumulativeParseResult $ map parseChunk chunks where parseChunk :: (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef] parseChunk (mSourceLoc, source) = - (fmap . fmap) (mkUnboundEntityDef ps) <$> parseSource ps mSourceLoc source + (fmap . fmap) (mkUnboundEntityDef ps) <$> parseSource ps mSourceLoc source entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) @@ -206,7 +207,7 @@ entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) getDbName ps (unEntityNameHS entNameHS) - (parsedEntityDefEntityAttributes parsedEntDef) + (attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef) -- | This type represents an @Id@ declaration in the QuasiQuoted syntax. -- @@ -527,12 +528,11 @@ mkUnboundEntityDef ps parsedEntDef = EntityIdField $ maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField , entityAttrs = - parsedEntityDefEntityAttributes parsedEntDef - , entityFields = - [] + attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef + , entityFields = [] , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs , entityForeigns = [] - , entityDerives = concat $ mapMaybe takeDerives textAttribs + , entityDerives = concat $ mapMaybe takeDerives (textFields ++ textDirectives) , entityExtra = parsedEntityDefExtras parsedEntDef , entitySum = parsedEntityDefIsSum parsedEntDef , entityComments = @@ -546,19 +546,22 @@ mkUnboundEntityDef ps parsedEntDef = (entNameHS, entNameDB) = entityNamesFromParsedDef ps parsedEntDef - attribs = - parsedEntityDefFieldAttributes parsedEntDef + fields = parsedEntityDefFields parsedEntDef + directives = parsedEntityDefDirectives parsedEntDef cols :: [UnboundFieldDef] - cols = foldMap (toList . commentedField ps) attribs + cols = foldMap (toList . commentedField ps) fields + + textFields :: [[Text]] + textFields = entityFieldContent . fst <$> fields - textAttribs :: [[Text]] - textAttribs = fmap tokenContent . fst <$> attribs + textDirectives :: [[Text]] + textDirectives = directiveContent . fst <$> directives entityConstraintDefs = foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) - textAttribs + (textFields ++ textDirectives) idField = case entityConstraintDefsIdField entityConstraintDefs of @@ -574,10 +577,10 @@ mkUnboundEntityDef ps parsedEntDef = commentedField :: PersistSettings - -> ([Token], Maybe Text) + -> (EntityField, Maybe Text) -> Maybe UnboundFieldDef - commentedField s (tokens, mCommentText) = do - unb <- takeColsEx s (tokenContent <$> tokens) + commentedField s (field, mCommentText) = do + unb <- takeColsEx s (entityFieldContent field) pure $ unb{unboundFieldComments = mCommentText} autoIdField :: FieldDef diff --git a/persistent/Database/Persist/Quasi/Internal/ModelParser.hs b/persistent/Database/Persist/Quasi/Internal/ModelParser.hs index a3c8b26ad..7e8162a1a 100644 --- a/persistent/Database/Persist/Quasi/Internal/ModelParser.hs +++ b/persistent/Database/Persist/Quasi/Internal/ModelParser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,23 +6,22 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} module Database.Persist.Quasi.Internal.ModelParser ( SourceLoc (..) - , Token (..) - , tokenContent - , anyToken - , ParsedEntityDef - , parsedEntityDefComments - , parsedEntityDefEntityName - , parsedEntityDefIsSum - , parsedEntityDefEntityAttributes - , parsedEntityDefFieldAttributes - , parsedEntityDefExtras - , parsedEntityDefSpan + , Attribute (..) + , attribute + , attributeContent + , Directive (..) + , directiveContent + , EntityField (..) + , entityField + , entityFieldContent + , FieldName (..) + , fieldName + , ParsedEntityDef (..) , parseSource - , memberBlockAttrs + , memberEntityFields , ParserWarning , parserWarningMessage , ParseResult @@ -34,7 +34,7 @@ module Database.Persist.Quasi.Internal.ModelParser ) where import Control.Applicative (Alternative) -import Control.Monad (MonadPlus, mzero, void) +import Control.Monad (MonadPlus, void) import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.State import Control.Monad.Writer @@ -42,7 +42,7 @@ import Data.Char (isSpace) import Data.Either (partitionEithers) import Data.Foldable (fold) import Data.Functor.Identity -import Data.List (find, intercalate) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M @@ -52,11 +52,12 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Data.Void +import Database.Persist.Quasi.Internal.TypeParser import Database.Persist.Quasi.PersistSettings.Internal import Database.Persist.Types import Database.Persist.Types.SourceSpan import Language.Haskell.TH.Syntax (Lift) -import Text.Megaparsec hiding (Token) +import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import qualified Text.Megaparsec.Stream as TMS @@ -101,6 +102,7 @@ newtype Parser a = Parser , MonadState ExtraState , MonadReader PersistSettings , MonadParsec Void String + , MonadFail ) type EntityParseError = ParseErrorBundle String Void @@ -211,19 +213,18 @@ tryOrWarn msg p l r = do else parseError err -- | Attempts to parse with a provided parser. If it fails with an error matching --- the provided predicate, it registers a delayed error with the provided message and falls +-- the provided predicate, it registers a delayed error and falls -- back to the second provided parser. -- -- This is useful when registering errors in space consumers and other parsers that are called -- with `try`, since a non-delayed error in this context will cause backtracking and not -- get reported to the user. tryOrRegisterError - :: String - -> (ParseError String Void -> Bool) + :: (ParseError String Void -> Bool) -> Parser a -> Parser a -> Parser a -tryOrRegisterError msg p l r = do +tryOrRegisterError p l r = do parserState <- getParserState withRecovery (delayedError $ statePosState parserState) l where @@ -244,7 +245,7 @@ tryOrReport -> Parser a -> Parser a tryOrReport level msg p l r = case level of - Just LevelError -> tryOrRegisterError msg p l r + Just LevelError -> tryOrRegisterError p l r Just LevelWarning -> tryOrWarn msg p l r Nothing -> r @@ -258,37 +259,113 @@ data SourceLoc = SourceLoc } deriving (Show, Lift) --- @since 2.16.0.0 -data Token - = Quotation Text - | Equality Text Text +-- | An attribute of an entity field definition or a directive. +-- +-- @since 2.17.1.0 +data Attribute + = Assignment Text Text | Parenthetical Text - | BlockKey Text | PText Text + | -- | Quoted field attributes are deprecated since 2.17.1.0. + Quotation Text deriving (Eq, Ord, Show) +-- | The name of an entity block or extra block. +-- +-- @since 2.17.1.0 +newtype BlockKey = BlockKey Text + deriving (Show) + +-- | A parsed comment or doc comment. +-- -- @since 2.16.0.0 data CommentToken = DocComment Text | Comment Text deriving (Eq, Ord, Show) --- | Converts a token into a Text representation for second-stage parsing or presentation to the user +-- | Converts an attribute into a Text representation for second-stage parsing or +-- presentation to the user -- -- @since 2.16.0.0 -tokenContent :: Token -> Text -tokenContent = \case - Quotation s -> s - Equality l r -> mconcat [l, "=", r] +attributeContent :: Attribute -> Text +attributeContent = \case + Assignment l r -> mconcat [l, "=", r] Parenthetical s -> s PText s -> s - BlockKey s -> s + Quotation s -> s + +-- | Converts a directive into a Text representation for second-stage parsing or +-- presentation to the user +-- +-- @since 2.17.1.0 +directiveContent :: Directive -> [Text] +directiveContent d = + [directiveNameContent $ directiveName d] + <> (attributeContent <$> directiveAttributes d) + +entityFieldContent :: EntityField -> [Text] +entityFieldContent f = + [ fieldNameAndStrictnessAsText f + , (typeExprContent . entityFieldType) f + ] + ++ fmap attributeContent (entityFieldAttributes f) + +blockKeyContent :: BlockKey -> Text +blockKeyContent (BlockKey t) = t + +directiveNameContent :: DirectiveName -> Text +directiveNameContent (DirectiveName t) = t + +-- | Generates the field name of an EntityField, accompanied by +-- its strictness sigil, if one is present. +-- This is only needed temporarily, and can eventually be refactored away. +-- +-- @since 2.17.1.0 +fieldNameAndStrictnessAsText :: EntityField -> Text +fieldNameAndStrictnessAsText f = + let + s = case entityFieldStrictness f of + Just Strict -> "!" + Just Lazy -> "~" + Nothing -> "" + (FieldName fn) = entityFieldName f + in + s <> fn commentContent :: CommentToken -> Text commentContent = \case Comment s -> s DocComment s -> s +quotedAttributeErrorMessage :: String +quotedAttributeErrorMessage = "Unexpected quotation mark in field or directive attribute" + +attribute :: Parser Attribute +attribute = do + quotedFieldAttributeErrorLevel <- asks psQuotedArgumentErrorLevel + tryOrReport + quotedFieldAttributeErrorLevel + "Quoted field attributes are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0" + isQuotedAttributeError + attribute' + (Quotation . Text.pack <$> quotation) + where + isQuotedAttributeError (FancyError _ s) = s == Set.singleton (ErrorFail quotedAttributeErrorMessage) + isQuotedAttributeError _ = False + +attribute' :: Parser Attribute +attribute' = do + q <- lookAhead (optional $ char '"') + case q of + Just _ -> fail quotedAttributeErrorMessage + Nothing -> + choice + [ try assignment + , parenthetical + , ptext + ] + docComment :: Parser (SourcePos, CommentToken) docComment = do pos <- getSourcePos @@ -365,6 +442,9 @@ spaceConsumerN = skipComment empty +-- This catch-all character class is used in a variety of places, and includes characters +-- which have syntactic function. As we continue to iterate on the parser, we may want to consider +-- shrinking or eliminating `contentChar`. contentChar :: Parser Char contentChar = choice @@ -408,23 +488,28 @@ charLiteral = label "literal character" $ do _ -> unexpected (Tokens $ char2 :| []) _ -> pure char1 -equality :: Parser Token -equality = label "equality expression" $ do +assignment :: Parser Attribute +assignment = label "assignment expression" $ do L.lexeme spaceConsumer $ do lhs <- some contentChar _ <- char '=' rhs <- choice - [ quotation' + [ quotation , sqlLiteral , parentheticalInner + , try sqlFunctionApplication , some $ contentChar <|> char '(' <|> char ')' ] - pure $ Equality (Text.pack lhs) (Text.pack rhs) + pure $ Assignment (Text.pack lhs) (Text.pack rhs) where parentheticalInner = do str <- parenthetical' pure . init . drop 1 $ str + sqlFunctionApplication = do + fn <- some contentChar + argString <- parentheticalInner + pure $ mconcat [fn, "(", argString, ")"] sqlTypeName :: Parser String sqlTypeName = @@ -449,15 +534,10 @@ sqlLiteral = label "SQL literal" $ do , fromMaybe "" st ] -quotation :: Parser Token -quotation = label "quotation" $ do - str <- L.lexeme spaceConsumer quotation' - pure . Quotation $ Text.pack str - -quotation' :: Parser String -quotation' = char '"' *> manyTill charLiteral (char '"') +quotation :: Parser String +quotation = char '"' *> manyTill charLiteral (char '"') -parenthetical :: Parser Token +parenthetical :: Parser Attribute parenthetical = label "parenthetical" $ do str <- L.lexeme spaceConsumer parenthetical' pure . Parenthetical . Text.pack . init . drop 1 $ str @@ -470,33 +550,41 @@ parenthetical' = do q = mconcat <$> some (c <|> parenthetical') c = (: []) <$> choice [contentChar, nonLineSpaceChar, char '"'] -blockKey :: Parser Token +blockKey :: Parser BlockKey blockKey = label "block key" $ do fl <- upperChar rl <- many alphaNumChar pure . BlockKey . Text.pack $ fl : rl -ptext :: Parser Token -ptext = label "plain token" $ do +fieldStrictness :: Parser FieldStrictness +fieldStrictness = + label "strictness sigil" $ + (Strict <$ char '!') <|> (Lazy <$ char '~') + +fieldName :: Parser FieldName +fieldName = label "field name" $ do + fl <- lowerChar + rl <- many fieldNameChar + pure . FieldName . Text.pack $ fl : rl + where + fieldNameChar = + choice + [ alphaNumChar + , char '_' + ] + +ptext :: Parser Attribute +ptext = label "plain attribute" $ do str <- L.lexeme spaceConsumer $ some contentChar pure . PText . Text.pack $ str --- @since 2.16.0.0 -anyToken :: Parser Token -anyToken = - choice - [ try equality - , quotation - , parenthetical - , ptext - ] - data ParsedEntityDef = ParsedEntityDef { parsedEntityDefComments :: [Text] , parsedEntityDefEntityName :: EntityNameHS , parsedEntityDefIsSum :: Bool - , parsedEntityDefEntityAttributes :: [Attr] - , parsedEntityDefFieldAttributes :: [([Token], Maybe Text)] + , parsedEntityDefEntityAttributes :: [Attribute] + , parsedEntityDefFields :: [(EntityField, Maybe Text)] + , parsedEntityDefDirectives :: [(Directive, Maybe Text)] , parsedEntityDefExtras :: M.Map Text [ExtraLine] , parsedEntityDefSpan :: Maybe SourceSpan } @@ -511,7 +599,7 @@ data DocCommentBlock = DocCommentBlock data EntityHeader = EntityHeader { entityHeaderSum :: Bool , entityHeaderTableName :: Text - , entityHeaderRemainingTokens :: [Token] + , entityHeaderRemainingAttributes :: [Attribute] , entityHeaderPos :: SourcePos } deriving (Show) @@ -531,23 +619,33 @@ entityBlockLastPos eb = case entityBlockMembers eb of [] -> entityBlockFirstPos eb members -> maximum $ fmap memberEndPos members -entityBlockBlockAttrs :: EntityBlock -> [BlockAttr] -entityBlockBlockAttrs = foldMap f <$> entityBlockMembers +entityBlockEntityFields :: EntityBlock -> [EntityField] +entityBlockEntityFields = foldMap f <$> entityBlockMembers where f m = case m of MemberExtraBlock _ -> [] - MemberBlockAttr ba -> [ba] + MemberEntityField ba -> [ba] + MemberDirective _ -> [] entityBlockExtraBlocks :: EntityBlock -> [ExtraBlock] entityBlockExtraBlocks = foldMap f <$> entityBlockMembers where f m = case m of MemberExtraBlock eb -> [eb] - MemberBlockAttr _ -> [] + MemberEntityField _ -> [] + MemberDirective _ -> [] + +entityBlockDirectives :: EntityBlock -> [Directive] +entityBlockDirectives = foldMap f <$> entityBlockMembers + where + f m = case m of + MemberExtraBlock _ -> [] + MemberEntityField _ -> [] + MemberDirective bd -> [bd] data ExtraBlockHeader = ExtraBlockHeader { extraBlockHeaderKey :: Text - , extraBlockHeaderRemainingTokens :: [Token] + , extraBlockHeaderRemainingAttributes :: [Attribute] , extraBlockHeaderPos :: SourcePos } deriving (Show) @@ -555,53 +653,86 @@ data ExtraBlockHeader = ExtraBlockHeader data ExtraBlock = ExtraBlock { extraBlockDocCommentBlock :: Maybe DocCommentBlock , extraBlockExtraBlockHeader :: ExtraBlockHeader - , extraBlockMembers :: NonEmpty Member + , extraBlockLines :: NonEmpty ExtraBlockLine + } + deriving (Show) + +data FieldStrictness = Strict | Lazy + deriving (Show) + +newtype FieldName = FieldName Text + deriving (Show, Eq) + +newtype DirectiveName = DirectiveName Text + deriving (Show, Eq) + +data EntityField = EntityField + { entityFieldDocCommentBlock :: Maybe DocCommentBlock + , entityFieldStrictness :: Maybe FieldStrictness + , entityFieldName :: FieldName + , entityFieldType :: TypeExpr + , entityFieldAttributes :: [Attribute] + , entityFieldPos :: SourcePos } deriving (Show) -data BlockAttr = BlockAttr - { blockAttrDocCommentBlock :: Maybe DocCommentBlock - , blockAttrTokens :: [Token] - , blockAttrPos :: SourcePos +data Directive = Directive + { directiveDocCommentBlock :: Maybe DocCommentBlock + , directiveName :: DirectiveName + , directiveAttributes :: [Attribute] + , directivePos :: SourcePos } deriving (Show) -data Member = MemberExtraBlock ExtraBlock | MemberBlockAttr BlockAttr +data Member + = MemberExtraBlock ExtraBlock + | MemberEntityField EntityField + | MemberDirective Directive + deriving (Show) + +data ExtraBlockLine = ExtraBlockLine + { extraBlockLineDocCommentBlock :: Maybe DocCommentBlock + , extraBlockLineTokens :: [String] + , extraBlockLinePos :: SourcePos + } deriving (Show) -- | The source position at the beginning of the member's final line. memberEndPos :: Member -> SourcePos -memberEndPos (MemberBlockAttr fs) = blockAttrPos fs -memberEndPos (MemberExtraBlock ex) = memberEndPos . NEL.last . extraBlockMembers $ ex +memberEndPos (MemberEntityField fs) = entityFieldPos fs +memberEndPos (MemberDirective d) = directivePos d +memberEndPos (MemberExtraBlock ex) = extraBlockLinePos . NEL.last . extraBlockLines $ ex --- | Represents an entity member as a list of BlockAttrs +-- | Represents an entity member as a list of EntityFields -- -- @since 2.16.0.0 -memberBlockAttrs :: Member -> [BlockAttr] -memberBlockAttrs (MemberBlockAttr fs) = [fs] -memberBlockAttrs (MemberExtraBlock ex) = foldMap memberBlockAttrs . extraBlockMembers $ ex +memberEntityFields :: Member -> [EntityField] +memberEntityFields (MemberEntityField fs) = [fs] +memberEntityFields (MemberDirective _) = [] +memberEntityFields (MemberExtraBlock _) = [] extraBlocksAsMap :: [ExtraBlock] -> M.Map Text [ExtraLine] extraBlocksAsMap exs = M.fromList $ fmap asPair exs where asPair ex = - (extraBlockHeaderKey . extraBlockExtraBlockHeader $ ex, extraLines ex) - extraLines ex = foldMap asExtraLine (extraBlockMembers ex) - asExtraLine (MemberBlockAttr fs) = [tokenContent <$> blockAttrTokens fs] - asExtraLine _ = [] + ( extraBlockHeaderKey . extraBlockExtraBlockHeader $ ex + , NEL.toList (extraLines ex) + ) + extraLines :: ExtraBlock -> NonEmpty [Text] + extraLines ex = fmap Text.pack . extraBlockLineTokens <$> extraBlockLines ex entityHeader :: Parser EntityHeader entityHeader = do pos <- getSourcePos plus <- optional (char '+') en <- validHSpace *> L.lexeme spaceConsumer blockKey - rest <- L.lexeme spaceConsumer (many anyToken) + rest <- L.lexeme spaceConsumer (many attribute) _ <- setLastDocumentablePosition pure EntityHeader { entityHeaderSum = isJust plus - , entityHeaderTableName = tokenContent en - , entityHeaderRemainingTokens = rest + , entityHeaderTableName = blockKeyContent en + , entityHeaderRemainingAttributes = rest , entityHeaderPos = pos } @@ -627,7 +758,7 @@ getDcb = do let candidates = dropWhile (\(_sp, ct) -> not (isDocComment ct)) comments filteredCandidates = dropWhile (commentIsIncorrectlyPositioned es) candidates - pure $ docCommentBlockFromPositionedTokens filteredCandidates + pure $ docCommentBlockFromPositionedAttributes filteredCandidates where commentIsIncorrectlyPositioned :: ExtraState -> (SourcePos, CommentToken) -> Bool @@ -638,51 +769,110 @@ getDcb = do extraBlock :: Parser Member extraBlock = L.indentBlock spaceConsumerN innerParser where - mkExtraBlockMember dcb (header, blockAttrs) = + mkExtraBlockMember dcb (header, extraBlockLines) = MemberExtraBlock ExtraBlock { extraBlockExtraBlockHeader = header - , extraBlockMembers = ensureNonEmpty blockAttrs + , extraBlockLines = ensureNonEmpty extraBlockLines , extraBlockDocCommentBlock = dcb } - ensureNonEmpty members = case NEL.nonEmpty members of + ensureNonEmpty lines = case NEL.nonEmpty lines of Just nel -> nel - Nothing -> error "unreachable" -- members is known to be non-empty + Nothing -> error "unreachable" -- lines is known to be non-empty innerParser = do dcb <- getDcb header <- extraBlockHeader pure $ - L.IndentSome Nothing (return . mkExtraBlockMember dcb . (header,)) blockAttr + L.IndentSome + Nothing + (return . mkExtraBlockMember dcb . (header,)) + extraBlockLine extraBlockHeader :: Parser ExtraBlockHeader extraBlockHeader = do pos <- getSourcePos tn <- L.lexeme spaceConsumer blockKey - rest <- L.lexeme spaceConsumer (many anyToken) + rest <- L.lexeme spaceConsumer (many attribute) _ <- setLastDocumentablePosition pure $ ExtraBlockHeader - { extraBlockHeaderKey = tokenContent tn - , extraBlockHeaderRemainingTokens = rest + { extraBlockHeaderKey = blockKeyContent tn + , extraBlockHeaderRemainingAttributes = rest , extraBlockHeaderPos = pos } -blockAttr :: Parser Member -blockAttr = do +extraBlockLine :: Parser ExtraBlockLine +extraBlockLine = do + dcb <- getDcb + pos <- getSourcePos + tokens <- some $ L.lexeme spaceConsumer (some contentChar) + _ <- setLastDocumentablePosition + pure $ + ExtraBlockLine + { extraBlockLineDocCommentBlock = dcb + , extraBlockLineTokens = tokens + , extraBlockLinePos = pos + } + +entityField :: Parser Member +entityField = do + dcb <- getDcb + pos <- getSourcePos + ss <- optional fieldStrictness + fn <- L.lexeme spaceConsumer fieldName + ft <- L.lexeme spaceConsumer typeExpr -- Note that `typeExpr` consumes outer parentheses. + fa <- L.lexeme spaceConsumer (many attribute) + _ <- setLastDocumentablePosition + lookAhead (void newline <|> eof) + pure $ + MemberEntityField + EntityField + { entityFieldDocCommentBlock = dcb + , entityFieldStrictness = ss + , entityFieldName = fn + , entityFieldType = ft + , entityFieldAttributes = fa + , entityFieldPos = pos + } + +directiveNameP :: Parser DirectiveName +directiveNameP = + label "directive name" $ + DirectiveName . Text.pack + <$> choice + [ string "deriving" + , directiveName' + ] + where + directiveName' = do + fl <- upperChar + rl <- many alphaNumChar + pure (fl : rl) + +directive :: Parser Member +directive = do dcb <- getDcb pos <- getSourcePos - line <- some anyToken + dn <- L.lexeme spaceConsumer directiveNameP + args <- many $ L.lexeme spaceConsumer attribute _ <- setLastDocumentablePosition + lookAhead (void newline <|> eof) pure $ - MemberBlockAttr - BlockAttr - { blockAttrDocCommentBlock = dcb - , blockAttrTokens = line - , blockAttrPos = pos + MemberDirective + Directive + { directiveDocCommentBlock = dcb + , directiveName = dn + , directiveAttributes = args + , directivePos = pos } member :: Parser Member -member = try extraBlock <|> blockAttr +member = + choice + [ try extraBlock + , directive + , entityField + ] entityBlock :: Parser EntityBlock entityBlock = do @@ -710,9 +900,9 @@ isDocComment tok = case tok of DocComment _ -> True _ -> False -docCommentBlockFromPositionedTokens +docCommentBlockFromPositionedAttributes :: [(SourcePos, CommentToken)] -> Maybe DocCommentBlock -docCommentBlockFromPositionedTokens ptoks = +docCommentBlockFromPositionedAttributes ptoks = case NEL.nonEmpty ptoks of Nothing -> Nothing Just nel -> @@ -744,7 +934,8 @@ toParsedEntityDef mSourceLoc eb = , parsedEntityDefEntityName = entityNameHS , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entityAttributes - , parsedEntityDefFieldAttributes = parsedFieldAttributes + , parsedEntityDefFields = parsedFields + , parsedEntityDefDirectives = parsedDirectives , parsedEntityDefExtras = extras , parsedEntityDefSpan = mSpan } @@ -754,13 +945,15 @@ toParsedEntityDef mSourceLoc eb = [] docCommentBlockLines (entityBlockDocCommentBlock eb) - entityAttributes = - tokenContent <$> (entityHeaderRemainingTokens . entityBlockEntityHeader) eb + entityAttributes = entityHeaderRemainingAttributes . entityBlockEntityHeader $ eb isSum = entityHeaderSum . entityBlockEntityHeader $ eb entityNameHS = EntityNameHS . entityHeaderTableName . entityBlockEntityHeader $ eb - attributePair a = (blockAttrTokens a, docCommentBlockText <$> blockAttrDocCommentBlock a) - parsedFieldAttributes = fmap attributePair (entityBlockBlockAttrs eb) + fieldPair a = (a, docCommentBlockText <$> entityFieldDocCommentBlock a) + parsedFields = fmap fieldPair (entityBlockEntityFields eb) + + directivePair d = (d, docCommentBlockText <$> directiveDocCommentBlock d) + parsedDirectives = fmap directivePair (entityBlockDirectives eb) extras = extraBlocksAsMap (entityBlockExtraBlocks eb) filepath = maybe "" locFile mSourceLoc diff --git a/persistent/Database/Persist/Quasi/Internal/TypeParser.hs b/persistent/Database/Persist/Quasi/Internal/TypeParser.hs new file mode 100644 index 000000000..51d3d56bf --- /dev/null +++ b/persistent/Database/Persist/Quasi/Internal/TypeParser.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.Persist.Quasi.Internal.TypeParser + ( TypeExpr (..) + , TypeConstructor (..) + , typeExpr + , innerTypeExpr + , typeExprContent + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +-- | A parsed type expression. +-- +-- @since 2.17.1.0 +data TypeExpr + = TypeApplication TypeExpr [TypeExpr] + | TypeConstructorExpr TypeConstructor + | TypeLitString String + | TypeLitInt String + | TypeLitPromotedConstructor TypeConstructor + deriving (Show, Eq) + +-- | A parsed type constructor. +-- +-- @since 2.17.1.0 +data TypeConstructor + = ListConstructor + | TypeConstructor String + deriving (Show, Eq) + +-- | Parses a Persistent-style type expression. +-- Persistent's type expressions are largely similar to Haskell's, but with a few differences: +-- +-- 1. Syntactic sugar is not currently supported for constructing types other than List. +-- 2. Only certain typelevel literals are supported: Strings, Ints, and promoted type constructors. +-- 3. Because they must be parsed as part of an entity field definition, top-level applications +-- of non-nullary type constructors (except for the sugary List constructor) must +-- be parenthesized. +-- +-- VALID: Int +-- VALID: [Maybe Int] +-- VALID: (Maybe Int) +-- INVALID: Maybe Int +-- +-- @since 2.17.1.0 +typeExpr :: ((MonadParsec e String) m) => m TypeExpr +typeExpr = typeExpr' Outer + +-- | Parses a type expression in non-top-level contexts, where an unparenthesized type constructor +-- application is acceptable. +-- +-- @since 2.17.1.0 +innerTypeExpr :: ((MonadParsec e String) m) => m TypeExpr +innerTypeExpr = typeExpr' Inner + +data IsInner = Inner | Outer + +typeExpr' :: ((MonadParsec e String) m) => IsInner -> m TypeExpr +typeExpr' isInner = label "type expression" $ do + let + validEmbeddedApplications = case isInner of + Inner -> + [ simpleTypeApplication + , complexTypeApplication + ] + Outer -> [nullaryTypeApplication] + choice $ + validEmbeddedApplications + ++ [ whitespaceBetween '(' ')' innerTypeExpr + , listType + , typeLitPromotedConstructor + , typeLitString + , typeLitInt + ] + where + -- This is a proper subset of `simpleTypeApplication`. + nullaryTypeApplication :: ((MonadParsec e String) m) => m TypeExpr + nullaryTypeApplication = do + tc <- typeConstructor <* optional hspace + pure $ TypeApplication (TypeConstructorExpr tc) [] + +-- This does not parse sugary constructors such as the List constructor `[]`. +typeConstructor :: ((MonadParsec e String) m) => m TypeConstructor +typeConstructor = do + first <- upperChar + rest <- many $ choice [alphaNumChar, char '.', char '\''] + pure $ TypeConstructor (first : rest) + +whitespaceBetween :: ((MonadParsec e String) m) => Char -> Char -> m a -> m a +whitespaceBetween ldelim rdelim = + between (char ldelim *> optional hspace) (optional hspace *> char rdelim) + +complexTypeApplication :: ((MonadParsec e String) m) => m TypeExpr +complexTypeApplication = do + t <- whitespaceBetween '(' ')' innerTypeExpr <* hspace + args <- some (typeExpr <* optional hspace) + pure $ TypeApplication t args + +simpleTypeApplication :: ((MonadParsec e String) m) => m TypeExpr +simpleTypeApplication = do + tc <- typeConstructor <* optional hspace + args <- many (typeExpr <* optional hspace) + pure $ TypeApplication (TypeConstructorExpr tc) args + +typeLitString :: ((MonadParsec e String) m) => m TypeExpr +typeLitString = do + s <- char '"' *> manyTill L.charLiteral (char '"') + pure $ TypeLitString s + +typeLitInt :: ((MonadParsec e String) m) => m TypeExpr +typeLitInt = TypeLitInt <$> some digitChar + +typeLitPromotedConstructor :: ((MonadParsec e String) m) => m TypeExpr +typeLitPromotedConstructor = do + _ <- char '\'' <* optional hspace + TypeLitPromotedConstructor <$> typeConstructor + +listType :: ((MonadParsec e String) m) => m TypeExpr +listType = do + t <- whitespaceBetween '[' ']' innerTypeExpr + pure $ TypeApplication (TypeConstructorExpr ListConstructor) [t] + +-- | Given a TypeExpr, renders it back to a String in a canonical form that looks +-- normal to humans and is re-parseable when making an UnboundEntityDef that uses it. +-- +-- @since 2.17.1.0 +typeExprContent :: TypeExpr -> Text +typeExprContent = typeExprContent' Outer + +-- This is a little gnarly-looking. That's mostly due to attempting to avoid inserting +-- superfluous parentheses. +typeExprContent' :: IsInner -> TypeExpr -> Text +typeExprContent' isInner = \case + TypeLitString s -> + mconcat + [ "\"" + , T.pack s + , "\"" + ] + TypeLitInt s -> T.pack s + TypeLitPromotedConstructor tc -> "'" <> typeExprContent' isInner (TypeConstructorExpr tc) + TypeConstructorExpr (TypeConstructor s) -> T.pack s + TypeConstructorExpr ListConstructor -> "List" + TypeApplication (TypeConstructorExpr tc) args -> simpleTypeApplicationContent tc args isInner + TypeApplication t exps -> + mconcat + [ typeExprContent' Inner t + , " " + , T.intercalate " " $ fmap typeExprContent exps + ] + where + typeArgsListContent :: IsInner -> [TypeExpr] -> Text + typeArgsListContent i exps = T.intercalate " " $ fmap (typeExprContent' i) exps + + simpleTypeApplicationContent :: TypeConstructor -> [TypeExpr] -> IsInner -> Text + simpleTypeApplicationContent ListConstructor args _ = + mconcat + [ "[" + , typeArgsListContent Outer args + , "]" + ] + simpleTypeApplicationContent (TypeConstructor s) [] _ = T.pack s + simpleTypeApplicationContent (TypeConstructor s) exps Inner = + mconcat + [ "(" + , simpleTypeApplicationContent (TypeConstructor s) exps Outer + , ")" + ] + simpleTypeApplicationContent (TypeConstructor s) exps Outer = + mconcat + [ T.pack s + , " " + , typeArgsListContent Inner exps + ] diff --git a/persistent/Database/Persist/Quasi/PersistSettings.hs b/persistent/Database/Persist/Quasi/PersistSettings.hs index 8fd661cf9..764e2d5c1 100644 --- a/persistent/Database/Persist/Quasi/PersistSettings.hs +++ b/persistent/Database/Persist/Quasi/PersistSettings.hs @@ -20,6 +20,8 @@ module Database.Persist.Quasi.PersistSettings , setPsIdName , getPsTabErrorLevel , setPsTabErrorLevel + , getPsQuotedArgumentErrorLevel + , setPsQuotedArgumentErrorLevel ) where import Database.Persist.Quasi.PersistSettings.Internal diff --git a/persistent/Database/Persist/Quasi/PersistSettings/Internal.hs b/persistent/Database/Persist/Quasi/PersistSettings/Internal.hs index 03fb6a2aa..8fcfbde94 100644 --- a/persistent/Database/Persist/Quasi/PersistSettings/Internal.hs +++ b/persistent/Database/Persist/Quasi/PersistSettings/Internal.hs @@ -38,6 +38,11 @@ data PersistSettings = PersistSettings -- ^ Whether and with what severity to disallow tabs in entity source text. -- -- @since 2.16.0.0 + , psQuotedArgumentErrorLevel :: Maybe ParserErrorLevel + -- ^ Whether and with what severity to disallow quoted entity field attributes + -- and quoted directive arguments. + -- + -- @since 2.17.1.0 } defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings @@ -48,6 +53,7 @@ defaultPersistSettings = , psStrictFields = True , psIdName = "id" , psTabErrorLevel = Just LevelWarning + , psQuotedArgumentErrorLevel = Just LevelWarning } upperCaseSettings = defaultPersistSettings lowerCaseSettings = @@ -181,3 +187,22 @@ getPsTabErrorLevel = psTabErrorLevel setPsTabErrorLevel :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings setPsTabErrorLevel l ps = ps{psTabErrorLevel = l} + +-- | Retrieve the severity of the error generated when the parser encounters a +-- quoted entity field attribute or quoted directive argument. +-- If it is @Nothing@, quoted arguments are permitted in both entity field +-- definitions and directives. +-- +-- @since 2.17.1.0 +getPsQuotedArgumentErrorLevel :: PersistSettings -> Maybe ParserErrorLevel +getPsQuotedArgumentErrorLevel = psQuotedArgumentErrorLevel + +-- | Set the severity of the error generated when the parser encounters a +-- quoted entity field attribute. +-- If set to @Nothing@, quoted arguments are permitted in both entity field +-- definitions and directives. +-- +-- @since 2.17.1.0 +setPsQuotedArgumentErrorLevel + :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings +setPsQuotedArgumentErrorLevel l ps = ps{psQuotedArgumentErrorLevel = l} diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 039111391..b662b1c45 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.17.0.0 +version: 2.17.1.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -81,10 +81,11 @@ library Database.Persist.Names Database.Persist.PersistValue Database.Persist.Quasi - Database.Persist.Quasi.PersistSettings - Database.Persist.Quasi.PersistSettings.Internal Database.Persist.Quasi.Internal Database.Persist.Quasi.Internal.ModelParser + Database.Persist.Quasi.Internal.TypeParser + Database.Persist.Quasi.PersistSettings + Database.Persist.Quasi.PersistSettings.Internal Database.Persist.Sql Database.Persist.Sql.Migration Database.Persist.Sql.Types.Internal diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 17803d341..178115ba0 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -16,15 +16,19 @@ import qualified Data.Set as Set import qualified Data.Text as T import Database.Persist.EntityDef.Internal import Database.Persist.Quasi -import Database.Persist.Quasi.PersistSettings -import Database.Persist.Quasi.PersistSettings.Internal (psTabErrorLevel) import Database.Persist.Quasi.Internal import Database.Persist.Quasi.Internal.ModelParser +import Database.Persist.Quasi.Internal.TypeParser +import Database.Persist.Quasi.PersistSettings +import Database.Persist.Quasi.PersistSettings.Internal + ( psQuotedArgumentErrorLevel + , psTabErrorLevel + ) import Database.Persist.Types import Test.Hspec import Test.QuickCheck -import Text.Shakespeare.Text (st) import Text.Megaparsec (errorBundlePretty, some) +import Text.Shakespeare.Text (st) defs :: T.Text -> [UnboundEntityDef] defs = defsWithSettings lowerCaseSettings @@ -32,10 +36,11 @@ defs = defsWithSettings lowerCaseSettings defsSnake :: T.Text -> [UnboundEntityDef] defsSnake = defsWithSettings $ setPsUseSnakeCaseForeignKeys lowerCaseSettings -defsWithWarnings :: PersistSettings -> T.Text -> (Set ParserWarning, [UnboundEntityDef]) +defsWithWarnings + :: PersistSettings -> T.Text -> (Set ParserWarning, [UnboundEntityDef]) defsWithWarnings ps t = case cpr of - (warnings, Right res) -> (warnings, res) - (_warnings, Left errs) -> error $ renderErrors errs + (warnings, Right res) -> (warnings, res) + (_warnings, Left errs) -> error $ renderErrors errs where cpr = parse ps [(Nothing, t)] @@ -46,15 +51,28 @@ defsWithSettings ps t = snd $ defsWithWarnings ps t warningSpecs :: Spec warningSpecs = describe "Quasi" $ do - describe "parser settings" $ do + describe "psTabErrorLevel parser setting" $ do let definitions = T.pack "User\n\tId Text\n\tname String" - (warnings, [user]) = defsWithWarnings lowerCaseSettings{ psTabErrorLevel = Just LevelWarning } definitions + (warnings, [user]) = + defsWithWarnings lowerCaseSettings { psTabErrorLevel = Just LevelWarning + } + definitions it "generates warnings" $ do Set.map parserWarningMessage warnings `shouldBe` [ "use spaces instead of tabs\n2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n" , "use spaces instead of tabs\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n" ] + describe "psQuotedArgumentErrorLevel parser setting" $ do + let + definitions = T.pack "User\n Id \"Text\"\n name String\n deriving \"Eq\"" + (warnings, [user]) = + defsWithWarnings lowerCaseSettings { psQuotedArgumentErrorLevel = Just LevelWarning + } + definitions + it "generates warnings" $ do + Set.map parserWarningMessage warnings + `shouldBe` ["Quoted field attributes are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0\n2:5:\n |\n2 | Id \"Text\"\n | ^\nUnexpected quotation mark in field or directive attribute\n","Quoted field attributes are deprecated since 2.17.1.0, and will be removed in or after 2.18.0.0\n4:11:\n |\n4 | deriving \"Eq\"\n | ^\nUnexpected quotation mark in field or directive attribute\n"] #else warningSpecs :: Spec warningSpecs = pure () @@ -111,218 +129,453 @@ spec = describe "Quasi" $ do , unboundFieldGenerated = Nothing } - describe "tokenization" $ do + describe "type parsing" $ do let - tokenize :: String -> ParseResult [Token] - tokenize s = do - let (warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState (some anyToken) "" s - case res of - Left peb -> - (warnings, Left peb) - Right (tokens, _acc) -> (warnings, Right tokens) + parseType :: String -> ParseResult TypeExpr + parseType s = do + let + (warnings, res) = + runConfiguredParser defaultPersistSettings initialExtraState innerTypeExpr "" s + case res of + Left peb -> (warnings, Left peb) + Right (te, _acc) -> (warnings, Right te) + + isType typeStr expectedTypeExpr = do + let + (_warnings, Right te) = parseType typeStr + te `shouldBe` expectedTypeExpr + typeExprContent te `shouldBe` T.pack typeStr + + -- these are some helper functions to make expectations less verbose + simpleType s = (TypeApplication (TypeConstructorExpr (TypeConstructor s)) []) + typeApp s ts = (TypeApplication (TypeConstructorExpr (TypeConstructor s)) ts) + listOf t = (TypeApplication (TypeConstructorExpr ListConstructor) [t]) + + it "parses types of kind '*'" $ do + "String" `isType` simpleType "String" + + it "parses type constructors with dots" $ do + "ThisIs.AType" `isType` simpleType "ThisIs.AType" + + it "parses higher-kinded types" $ do + "Maybe String" `isType` typeApp "Maybe" [simpleType "String"] + + it "is greedy when parsing arguments to a type constructor" $ do + "Map String Int" `isType` typeApp "Map" [simpleType "String", simpleType "Int"] + + it "parses higher-kinded types when parameterized by complex types (1)" $ do + "Map String (Maybe [Int])" + `isType` typeApp "Map" [simpleType "String", typeApp "Maybe" [listOf (simpleType "Int")]] + + it "parses higher-kinded types when parameterized by complex types (2)" $ do + "Map (Maybe Int) [Int]" + `isType` typeApp "Map" [(typeApp "Maybe" [simpleType "Int"]), listOf (simpleType "Int")] + + it "parses type expressions constructed by a partially parameterized type" $ do + "(Map String) [Int]" + `isType` TypeApplication + (typeApp "Map" [(simpleType "String")]) + [listOf (simpleType "Int")] + + it "parses lists of lists" $ do + "[[Maybe String]]" + `isType` listOf (listOf (typeApp "Maybe" [simpleType "String"])) + + it "parses list types of complex types" $ do + "[(Map String) [Int]]" + `isType` listOf + ( TypeApplication + (typeApp "Map" [(simpleType "String")]) + [listOf (simpleType "Int")] + ) + + it "parses type-level String literals" $ do + "Labelled \"abcd\"" `isType` typeApp "Labelled" [TypeLitString "abcd"] + + it "parses type-level Int literals" $ do + "Val 3" `isType` typeApp "Val" [TypeLitInt "3"] + + it "parses promoted type constructors" $ do + "'Maybe" `isType` TypeLitPromotedConstructor (TypeConstructor "Maybe") + + describe "field name parsing" $ do + let + parseFieldName :: String -> ParseResult FieldName + parseFieldName s = do + let + (warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState fieldName "" s + case res of + Left peb -> + (warnings, Left peb) + Right (fn, _acc) -> (warnings, Right fn) + + it "parses alphanumeric field names" $ + parseFieldName "asdf100" + `shouldBe` ([], Right (FieldName "asdf100")) + + it "parses alphanumeric field names with underscores" $ + parseFieldName "asdf_100" + `shouldBe` ([], Right (FieldName "asdf_100")) + + describe "attribute parsing" $ do + let + parseAttributes :: String -> ParseResult [Attribute] + parseAttributes s = do + let + (warnings, res) = + runConfiguredParser + defaultPersistSettings + initialExtraState + (some attribute) + "" + s + case res of + Left peb -> + (warnings, Left peb) + Right (tokens, _acc) -> (warnings, Right tokens) it "handles normal words" $ - tokenize "foo bar baz" - `shouldBe` ([], Right - ( [ PText "foo" - , PText "bar" - , PText "baz" - ] - ) + parseAttributes "foo bar baz" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar" + , PText "baz" + ] + ) + ) + + it "handles bangs" $ + parseAttributes "foo !bar baz" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "!bar" + , PText "baz" + ] + ) ) it "handles numbers" $ - tokenize "one (Finite 1)" - `shouldBe` ([], Right - ( [ PText "one" - , Parenthetical "Finite 1" - ] - ) + parseAttributes "one (Finite 1)" + `shouldBe` ( [] + , Right + ( [ PText "one" + , Parenthetical "Finite 1" + ] + ) ) it "handles quotes" $ - tokenize "\"foo bar\" \"baz\"" - `shouldBe` ([], Right - ( [ Quotation "foo bar" - , Quotation "baz" - ] - ) + parseAttributes "abc=\"foo bar\" def=\"baz\"" + `shouldBe` ( [] + , Right + ( [ Assignment "abc" "foo bar" + , Assignment "def" "baz" + ] + ) ) it "handles SQL literals with no specified type" $ - tokenize "attr='[\"ab\\'cd\", 1, 2]'" - `shouldBe` ([], Right - ( [Equality "attr" "'[\"ab'cd\", 1, 2]'"] - ) + parseAttributes "attr='[\"ab\\'cd\", 1, 2]'" + `shouldBe` ( [] + , Right + ([Assignment "attr" "'[\"ab'cd\", 1, 2]'"]) ) it "handles SQL literals with a specified type" $ - tokenize "attr='{\"\\'a\\'\": [1, 2.2, \"\\'3\\'\"]}'::type_name" - `shouldBe` ([], Right - ( [Equality "attr" "'{\"'a'\": [1, 2.2, \"'3'\"]}'::type_name"] - ) + parseAttributes "attr='{\"\\'a\\'\": [1, 2.2, \"\\'3\\'\"]}'::type_name" + `shouldBe` ( [] + , Right + ([Assignment "attr" "'{\"'a'\": [1, 2.2, \"'3'\"]}'::type_name"]) ) - it "should error if quotes are unterminated" $ do - (fmap . first) errorBundlePretty (tokenize "\"foo bar") - `shouldBe` ([], Left - ( "1:9:\n |\n1 | \"foo bar\n | ^\nunexpected end of input\nexpecting '\"' or literal character\n" - ) + it "handles commas in tokens" $ + parseAttributes "x=COALESCE(left,right) baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "COALESCE(left,right)" + , PText "baz" + ] + ) ) - it "handles commas in tokens" $ - tokenize "x=COALESCE(left,right) \"baz\"" - `shouldBe` ([], Right - ( [ Equality "x" "COALESCE(left,right)" - , Quotation "baz" - ] - ) + it "handles single quotes in tokens" $ + parseAttributes "x=blorp('blap') baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "blorp('blap')" + , PText "baz" + ] + ) + ) + + it "handles spaces in assignment RHSes" $ + parseAttributes "sql=blorp('blap', 'blip') baz" + `shouldBe` ( [] + , Right + ( [ Assignment "sql" "blorp('blap', 'blip')" + , PText "baz" + ] + ) ) it "handles quotes mid-token" $ - tokenize "x=\"foo bar\" \"baz\"" - `shouldBe` ([], Right - ( [ Equality "x" "foo bar" - , Quotation "baz" - ] - ) + parseAttributes "x=\"foo bar\" baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "foo bar" + , PText "baz" + ] + ) ) it "handles escaped quotes mid-token" $ - tokenize "x=\\\"foo bar\" \"baz\"" - `shouldBe` ([], Right - ( [ Equality "x" "\\\"foo" - , PText "bar\"" - , Quotation "baz" - ] - ) + parseAttributes "x=\\\"foo bar\" baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "\\\"foo" + , PText "bar\"" + , PText "baz" + ] + ) ) it "handles unnested parentheses" $ - tokenize "(foo bar) (baz)" - `shouldBe` ([], Right - ( [ Parenthetical "foo bar" - , Parenthetical "baz" - ] - ) + parseAttributes "(foo bar) (baz)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo bar" + , Parenthetical "baz" + ] + ) ) it "handles unnested parentheses mid-token" $ - tokenize "x=(foo bar) (baz)" - `shouldBe` ([], Right - ( [ Equality "x" "foo bar" - , Parenthetical "baz" - ] - ) + parseAttributes "x=(foo bar) (baz)" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "foo bar" + , Parenthetical "baz" + ] + ) ) it "handles nested parentheses" $ - tokenize "(foo (bar)) (baz)" - `shouldBe` ([], Right - ( [ Parenthetical "foo (bar)" - , Parenthetical "baz" - ] - ) + parseAttributes "(foo (bar)) (baz)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo (bar)" + , Parenthetical "baz" + ] + ) ) it "handles escaped quotation marks in plain tokens" $ - tokenize "foo bar\\\"baz" - `shouldBe` ([], Right - ( [ PText "foo" - , PText "bar\\\"baz" - ] - ) + parseAttributes "foo bar\\\"baz" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar\\\"baz" + ] + ) ) it "handles escaped quotation marks in quotations" $ - tokenize "foo \"bar\\\"baz\"" - `shouldBe` ([], Right - ( [ PText "foo" - , Quotation "bar\"baz" - ] - ) + parseAttributes "foo bar=\"baz\\\"quux\"" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , Assignment "bar" "baz\"quux" + ] + ) ) it "handles escaped quotation marks in equalities" $ - tokenize "y=\"baz\\\"\"" - `shouldBe` ([], Right - ( [ Equality "y" "baz\"" - ] - ) + parseAttributes "y=\"baz\\\"\"" + `shouldBe` ( [] + , Right + ( [ Assignment "y" "baz\"" + ] + ) ) it "handles escaped quotation marks in parentheticals" $ - tokenize "(foo \\\"bar)" - `shouldBe` ([], Right - ( [ Parenthetical "foo \\\"bar" - ] - ) + parseAttributes "(foo \\\"bar)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo \\\"bar" + ] + ) ) it "handles escaped parentheses in quotations" $ - tokenize "foo \"bar\\(baz\"" - `shouldBe` ([], Right - ( [ PText "foo" - , Quotation "bar(baz" - ] - ) + parseAttributes "foo bar=\"baz\\(quux\"" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , Assignment "bar" "baz(quux" + ] + ) ) it "handles escaped parentheses in plain tokens" $ - tokenize "foo bar\\(baz" - `shouldBe` ([], Right - ( [ PText "foo" - , PText "bar(baz" - ] - ) + parseAttributes "foo bar\\(baz" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar(baz" + ] + ) ) it "handles escaped parentheses in parentheticals" $ - tokenize "(foo \\(bar)" - `shouldBe` ([], Right - ( [ Parenthetical "foo (bar" - ] - ) + parseAttributes "(foo \\(bar)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo (bar" + ] + ) ) it "handles escaped parentheses in equalities" $ - tokenize "y=baz\\(" - `shouldBe` ([], Right - ( [ Equality "y" "baz(" - ] - ) + parseAttributes "y=baz\\(" + `shouldBe` ( [] + , Right + ( [ Assignment "y" "baz(" + ] + ) ) it "handles mid-token quote in later token" $ - tokenize "foo bar baz=(bin\")" - `shouldBe` ([], Right - ( [ PText "foo" - , PText "bar" - , Equality "baz" "bin\"" - ] - ) + parseAttributes "foo bar baz=(bin\")" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar" + , Assignment "baz" "bin\"" + ] + ) ) - describe "parser settings" $ do - let definitions = T.pack "User\n\tId Text\n\tname String" + describe "entity field parsing" $ do + let + parseField :: String -> ParseResult () + parseField s = do + let + (warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState entityField "" s + case res of + Left peb -> + (warnings, Left peb) + Right (_, _) -> (warnings, Right ()) + + it "should error if quotes are unterminated in an attribute" $ do + (fmap . first) errorBundlePretty (parseField "field String sql=\"foo bar") + `shouldBe` ( [] + , Left + ( "1:17:\n |\n1 | field String sql=\"foo bar\n | ^\nunexpected '='\nexpecting '!', '\"', ''', ',', '-', '.', ':', '[', '\\', ']', '_', '~', alphanumeric character, assignment expression, end of input, newline, parenthetical, or plain attribute\n" + ) + ) - describe "when configured to permit tabs" $ do + it "should error if quotes are unterminated in a type" $ do + (fmap . first) errorBundlePretty (parseField "field (Label \"unterminated)") + `shouldBe` ( [] + , Left + ( "1:28:\n |\n1 | field (Label \"unterminated)\n | ^\nunexpected end of input\nexpecting '\"' or literal character\n" + ) + ) + + describe "tab error level setting" $ do let - [user] = defsWithSettings lowerCaseSettings{ psTabErrorLevel = Nothing } definitions - it "permits tab indentation" $ - getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + definitions = T.pack "User\n\tId Text\n\tname String" + + describe "when configured to permit tabs" $ do + let + (warnings, [user]) = defsWithWarnings lowerCaseSettings{psTabErrorLevel = Nothing} definitions + + it "permits tab indentation" $ + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" - describe "when configured to warn on tabs" $ do + describe "when configured to warn on tabs" $ do + let + (warnings, [user]) = + defsWithWarnings + lowerCaseSettings{psTabErrorLevel = Just LevelWarning} + definitions + + it "permits tab indentation" $ + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + + describe "when configured to disallow tabs" $ do + let + [user] = + defsWithSettings + lowerCaseSettings{psTabErrorLevel = Just LevelError} + definitions + + it "rejects tab indentation" $ + evaluate (unboundEntityDef user) + `shouldErrorWithMessage` "2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n" + + describe "quoted attribute error level setting" $ do let - (warnings, [user]) = defsWithWarnings lowerCaseSettings{ psTabErrorLevel = Just LevelWarning } definitions - it "permits tab indentation" $ - getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + definitions = T.pack "User\n name String \"Maybe\"" - describe "when configured to disallow tabs" $ do + describe "when configured to warn on quoted attributes" $ do + let + (warnings, [user]) = + defsWithWarnings + lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelWarning} + definitions + + it "permits quoted attributes" $ + (unboundFieldAttrs <$> unboundEntityFields user) `shouldBe` [[FieldAttrMaybe]] + + describe "when configured to disallow quoted attributes" $ do + let + (warnings, [user]) = + defsWithWarnings + lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelError} + definitions + + it "rejects quoted attributes" $ + evaluate (unboundEntityDef user) + `shouldErrorWithMessage` "2:14:\n |\n2 | name String \"Maybe\"\n | ^\nUnexpected quotation mark in field or directive attribute\n" + + describe "and the definition has quotation marks in the type" $ do + let + definitionsWithTypeLevelString = T.pack "User\n name \"String\"\n deriving Show" + (warnings2, [user]) = + defsWithWarnings + lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelError} + definitionsWithTypeLevelString + it "parses successfully" $ + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + + describe "quoted directive argument error level setting" $ do let - [user] = defsWithSettings lowerCaseSettings{ psTabErrorLevel = Just LevelError } definitions - it "rejects tab indentation" $ - evaluate (unboundEntityDef user) `shouldErrorWithMessage` "2:1:\n |\n2 | Id Text\n | ^\nunexpected tab\nexpecting valid whitespace\n\n3:1:\n |\n3 | name String\n | ^\nunexpected tab\nexpecting valid whitespace\n" + definitions = T.pack "User\n name String\n deriving \"Show\"" + + describe "when configured to warn on quoted arguments" $ do + let + (warnings, [user]) = + defsWithWarnings + lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelWarning} + definitions + + it "permits quoted attributes" $ + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + + describe "when configured to disallow quoted arguments" $ do + let + (warnings, [user]) = + defsWithWarnings + lowerCaseSettings{psQuotedArgumentErrorLevel = Just LevelError} + definitions + + it "rejects quoted arguments" $ + evaluate (unboundEntityDef user) + `shouldErrorWithMessage` "3:11:\n |\n3 | deriving \"Show\"\n | ^\nUnexpected quotation mark in field or directive attribute\n" describe "parse" $ do let @@ -383,14 +636,37 @@ Car it "should parse the `entityUniques` field" $ do let - simplifyUnique unique = - (uniqueHaskell unique, uniqueFields unique) + simplifyUnique unique = + (uniqueHaskell unique, uniqueFields unique) (simplifyUnique <$> entityUniques (unboundEntityDef bicycle)) `shouldBe` [] (simplifyUnique <$> entityUniques (unboundEntityDef car)) - `shouldBe` [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")]) - ] + `shouldBe` [ (ConstraintNameHS "UniqueModel", [(FieldNameHS "model", FieldNameDB "model")]) + ] (simplifyUnique <$> entityUniques (unboundEntityDef vehicle)) `shouldBe` [] + it "should parse quoted attributes" $ do + let + [precompiledCacheParent] = + defs + [st| + PrecompiledCacheParent sql="precompiled_cache" + platformGhcDir FilePath "default=(hex(randomblob(16)))" + deriving Show + |] + (unboundFieldAttrs <$> unboundEntityFields precompiledCacheParent) + `shouldBe` [[FieldAttrDefault "(hex(randomblob(16)))"]] + + it "should parse entity block attributes with nested parens on equality rhs" $ do + let + [precompiledCacheParent] = + defs + [st| + PrecompiledCacheParent sql="precompiled_cache" + platformGhcDir FilePath default=(hex(randomblob(16))) + |] + (unboundFieldAttrs <$> unboundEntityFields precompiledCacheParent) + `shouldBe` [[FieldAttrDefault "hex(randomblob(16))"]] + it "should parse the `entityForeigns` field" $ do let [user, notification] = @@ -462,7 +738,7 @@ User let [user] = defs definitions evaluate (unboundEntityDef user) - `shouldErrorWithMessage` "4:20:\n |\n4 | age (Maybe Int\n | ^\nunexpected newline\nexpecting '!', '\"', ''', '(', ')', ',', '-', '.', ':', '[', '\\', ']', '_', '~', alphanumeric character, space, or tab\n" + `shouldErrorWithMessage` "4:20:\n |\n4 | age (Maybe Int\n | ^\nunexpected newline\nexpecting ''', ')', '.', alphanumeric character, type expression, or white space\n" it "errors on duplicate cascade update declarations" $ do let @@ -868,8 +1144,7 @@ WithFinite it "application" $ parseFieldType "Foo Bar" `shouldBe` Right - ( FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar" - ) + (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") it "application multiple" $ parseFieldType "Foo Bar Baz" `shouldBe` Right @@ -883,8 +1158,7 @@ WithFinite baz = FTTypeCon Nothing "Baz" parseFieldType "Foo (Bar Baz)" `shouldBe` Right - ( foo `FTApp` (bar `FTApp` baz) - ) + (foo `FTApp` (bar `FTApp` baz)) it "lists" $ do let foo = FTTypeCon Nothing "Foo" @@ -893,8 +1167,7 @@ WithFinite baz = FTTypeCon Nothing "Baz" parseFieldType "Foo [Bar] Baz" `shouldBe` Right - ( foo `FTApp` bars `FTApp` baz - ) + (foo `FTApp` bars `FTApp` baz) it "numeric type literals" $ do let expected = FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)) diff --git a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs index b4e694e57..ba52a89d6 100644 --- a/persistent/test/Database/Persist/TH/ForeignRefSpec.hs +++ b/persistent/test/Database/Persist/TH/ForeignRefSpec.hs @@ -1,4 +1,11 @@ {-# LANGUAGE DataKinds #-} +-- +-- DeriveAnyClass is not actually used by persistent-template +-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving +-- This was fixed by using DerivingStrategies to specify newtype deriving should be used. +-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled. +-- See https://github.com/yesodweb/persistent/issues/578 +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} @@ -13,21 +20,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} --- --- DeriveAnyClass is not actually used by persistent-template --- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving --- This was fixed by using DerivingStrategies to specify newtype deriving should be used. --- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled. --- See https://github.com/yesodweb/persistent/issues/578 -{-# LANGUAGE DeriveAnyClass #-} module Database.Persist.TH.ForeignRefSpec where -import Control.Applicative (Const(..)) +import Control.Applicative (Const (..)) import Data.Aeson import Data.ByteString.Lazy.Char8 () import Data.Coerce -import Data.Functor.Identity (Identity(..)) +import Data.Functor.Identity (Identity (..)) import Data.Int import qualified Data.List as List import Data.Proxy @@ -45,7 +45,9 @@ import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports -mkPersist sqlSettings [persistLowerCase| +mkPersist + sqlSettings + [persistLowerCase| HasCustomName sql=custom_name name Text @@ -96,8 +98,7 @@ spec = describe "ForeignRefSpec" $ do entityDef $ Proxy @HasCustomName it "should have a custom db name" $ do entityDB edef - `shouldBe` - EntityNameDB "custom_name" + `shouldBe` EntityNameDB "custom_name" it "should compile" $ do True `shouldBe` True @@ -110,8 +111,7 @@ spec = describe "ForeignRefSpec" $ do entityForeigns fpsDef it "has the right type" $ do foreignPrimarySourceFk_name_target (ForeignPrimarySource "asdf") - `shouldBe` - ForeignPrimaryKey "asdf" + `shouldBe` ForeignPrimaryKey "asdf" describe "Cascade" $ do describe "Explicit" $ do @@ -123,34 +123,33 @@ spec = describe "ForeignRefSpec" $ do childForeigns = entityForeigns childDef it "should have a single foreign reference defined" $ do - case entityForeigns childDef of - [a] -> - pure () - as -> - expectationFailure . mconcat $ - [ "Expected one foreign reference on childDef, " - , "got: " - , show as - ] + case entityForeigns childDef of + [a] -> + pure () + as -> + expectationFailure . mconcat $ + [ "(Explicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] let - [ForeignDef {..}] = + [ForeignDef{..}] = childForeigns describe "ChildExplicit" $ do it "should have the right target table" $ do - foreignRefTableHaskell `shouldBe` - EntityNameHS "ParentExplicit" - foreignRefTableDBName `shouldBe` - EntityNameDB "parent_explicit" + foreignRefTableHaskell + `shouldBe` EntityNameHS "ParentExplicit" + foreignRefTableDBName + `shouldBe` EntityNameDB "parent_explicit" it "should have the right cascade behavior" $ do foreignFieldCascade - `shouldBe` - FieldCascade - { fcOnUpdate = - Just Cascade - , fcOnDelete = - Just Cascade - } + `shouldBe` FieldCascade + { fcOnUpdate = + Just Cascade + , fcOnDelete = + Just Cascade + } it "is not nullable" $ do foreignNullable `shouldBe` False it "is to the Primary key" $ do @@ -168,11 +167,11 @@ spec = describe "ForeignRefSpec" $ do case childFields of [nameField, parentIdField] -> do it "parentId has reference" $ do - fieldReference parentIdField `shouldBe` - ForeignRef (EntityNameHS "ParentImplicit") + fieldReference parentIdField + `shouldBe` ForeignRef (EntityNameHS "ParentImplicit") as -> error . mconcat $ - [ "Expected one foreign reference on childDef, " + [ "(Implicit) Expected one foreign reference on childDef, " , "got: " , show as ]