persistent 2.17.0.0 → 2.17.1.0
raw patch · 10 files changed
+1954/−1268 lines, 10 files
Files
- ChangeLog.md +7/−0
- Database/Persist/Quasi.hs +934/−931
- Database/Persist/Quasi/Internal.hs +28/−25
- Database/Persist/Quasi/Internal/ModelParser.hs +302/−109
- Database/Persist/Quasi/Internal/TypeParser.hs +180/−0
- Database/Persist/Quasi/PersistSettings.hs +2/−0
- Database/Persist/Quasi/PersistSettings/Internal.hs +25/−0
- persistent.cabal +4/−3
- test/Database/Persist/QuasiSpec.hs +435/−162
- test/Database/Persist/TH/ForeignRefSpec.hs +37/−38
ChangeLog.md view
@@ -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)
Database/Persist/Quasi.hs view
@@ -4,934 +4,937 @@ {-# 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-<https://github.com/yesodweb/persistent/issues/241 attempt a migration each time you start your app>.--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 <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> 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-<https://github.com/yesodweb/persistent/blob/master/persistent-test/src/SumTypeTest.hs#L35 tests for this feature>-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 <https://github.com/yesodweb/persistent/issues/225 #225>|-+--------------------------------------------------------------------+--See <http://hackage.haskell.org/package/mysql-simple/docs/Database-MySQL-Simple-Result.html MySQL.Simple.Result>.--}-module Database.Persist.Quasi- ( parse- -- * 'PersistSettings'- , PersistSettings- , upperCaseSettings- , lowerCaseSettings- -- ** Getters and Setters- , getPsToDBName- , setPsToDBName- , setPsToFKName- , setPsUseSnakeCaseForeignKeys- , setPsUseSnakeCaseForiegnKeys- , getPsStrictFields- , setPsStrictFields- , getPsIdName- , setPsIdName- , getPsTabErrorLevel- , setPsTabErrorLevel- ) where--import Database.Persist.Quasi.PersistSettings-import Database.Persist.Quasi.Internal+-- |+-- 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+-- <https://github.com/yesodweb/persistent/issues/241 attempt a migration each time you start your app>.+--+-- 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 <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> 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+-- <https://github.com/yesodweb/persistent/blob/master/persistent-test/src/SumTypeTest.hs#L35 tests for this feature>+-- 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 <https://github.com/yesodweb/persistent/issues/225 #225>|+-- +--------------------------------------------------------------------++--+-- See <http://hackage.haskell.org/package/mysql-simple/docs/Database-MySQL-Simple-Result.html MySQL.Simple.Result>.+module Database.Persist.Quasi+ ( parse++ -- * 'PersistSettings'+ , PersistSettings+ , upperCaseSettings+ , lowerCaseSettings++ -- ** Getters and Setters+ , getPsToDBName+ , setPsToDBName+ , setPsToFKName+ , setPsUseSnakeCaseForeignKeys+ , setPsUseSnakeCaseForiegnKeys+ , getPsStrictFields+ , setPsStrictFields+ , getPsIdName+ , setPsIdName+ , getPsTabErrorLevel+ , setPsTabErrorLevel+ , getPsQuotedArgumentErrorLevel+ , setPsQuotedArgumentErrorLevel+ ) where++import Database.Persist.Quasi.Internal+import Database.Persist.Quasi.PersistSettings
Database/Persist/Quasi/Internal.hs view
@@ -16,7 +16,7 @@ , PersistSettings (..) , upperCaseSettings , lowerCaseSettings- , Token (..)+ , Attribute (..) , SourceLoc (..) , sourceLocFromTHLoc , parseFieldType@@ -61,13 +61,14 @@ 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 @@ -- | 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 @@ getDbName ps (unEntityNameHS entNameHS)- (parsedEntityDefEntityAttributes parsedEntDef)+ (attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef) -- | This type represents an @Id@ declaration in the QuasiQuoted syntax. --@@ -527,12 +528,11 @@ 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 @@ (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 - textAttribs :: [[Text]]- textAttribs = fmap tokenContent . fst <$> attribs+ textFields :: [[Text]]+ textFields = entityFieldContent . fst <$> fields + 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 @@ 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
Database/Persist/Quasi/Internal/ModelParser.hs view
@@ -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 @@ ) 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.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 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 @@ , MonadState ExtraState , MonadReader PersistSettings , MonadParsec Void String+ , MonadFail ) type EntityParseError = ParseErrorBundle String Void@@ -211,19 +213,18 @@ 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 @@ -> 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 @@ } 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 @@ 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 @@ _ -> 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 @@ , 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 @@ 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 EntityHeader = EntityHeader { entityHeaderSum :: Bool , entityHeaderTableName :: Text- , entityHeaderRemainingTokens :: [Token]+ , entityHeaderRemainingAttributes :: [Attribute] , entityHeaderPos :: SourcePos } deriving (Show)@@ -531,23 +619,33 @@ [] -> 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 ExtraBlock = ExtraBlock { extraBlockDocCommentBlock :: Maybe DocCommentBlock , extraBlockExtraBlockHeader :: ExtraBlockHeader- , extraBlockMembers :: NonEmpty Member+ , extraBlockLines :: NonEmpty ExtraBlockLine } deriving (Show) -data BlockAttr = BlockAttr- { blockAttrDocCommentBlock :: Maybe DocCommentBlock- , blockAttrTokens :: [Token]- , blockAttrPos :: SourcePos+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 Member = MemberExtraBlock ExtraBlock | MemberBlockAttr BlockAttr+data Directive = Directive+ { directiveDocCommentBlock :: Maybe DocCommentBlock+ , directiveName :: DirectiveName+ , directiveAttributes :: [Attribute]+ , directivePos :: SourcePos+ } deriving (Show) +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 @@ 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 @@ 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- line <- some anyToken+ tokens <- some $ L.lexeme spaceConsumer (some contentChar) _ <- setLastDocumentablePosition pure $- MemberBlockAttr- BlockAttr- { blockAttrDocCommentBlock = dcb- , blockAttrTokens = line- , blockAttrPos = pos+ 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+ dn <- L.lexeme spaceConsumer directiveNameP+ args <- many $ L.lexeme spaceConsumer attribute+ _ <- setLastDocumentablePosition+ lookAhead (void newline <|> eof)+ pure $+ 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 @@ 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 @@ , parsedEntityDefEntityName = entityNameHS , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entityAttributes- , parsedEntityDefFieldAttributes = parsedFieldAttributes+ , parsedEntityDefFields = parsedFields+ , parsedEntityDefDirectives = parsedDirectives , parsedEntityDefExtras = extras , parsedEntityDefSpan = mSpan }@@ -754,13 +945,15 @@ [] 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
+ Database/Persist/Quasi/Internal/TypeParser.hs view
@@ -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+ ]
Database/Persist/Quasi/PersistSettings.hs view
@@ -20,6 +20,8 @@ , setPsIdName , getPsTabErrorLevel , setPsTabErrorLevel+ , getPsQuotedArgumentErrorLevel+ , setPsQuotedArgumentErrorLevel ) where import Database.Persist.Quasi.PersistSettings.Internal
Database/Persist/Quasi/PersistSettings/Internal.hs view
@@ -38,6 +38,11 @@ -- ^ 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 @@ , psStrictFields = True , psIdName = "id" , psTabErrorLevel = Just LevelWarning+ , psQuotedArgumentErrorLevel = Just LevelWarning } upperCaseSettings = defaultPersistSettings lowerCaseSettings =@@ -181,3 +187,22 @@ 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}
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.17.0.0+version: 2.17.1.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -81,10 +81,11 @@ 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
test/Database/Persist/QuasiSpec.hs view
@@ -16,15 +16,19 @@ 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 @@ 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 @@ 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,219 +129,454 @@ , 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 ()) - describe "when configured to permit tabs" $ do+ 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"+ )+ )++ 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 warn on tabs" $ do+ 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+ 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 subject =@@ -383,14 +636,37 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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))
test/Database/Persist/TH/ForeignRefSpec.hs view
@@ -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.TH import TemplateTestImports -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| HasCustomName sql=custom_name name Text@@ -96,8 +98,7 @@ 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 @@ 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 @@ 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 @@ 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 ]