diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,15 +1,609 @@ # Changelog for persistent -## 2.10.5.4 +# 2.18.1.0 +* [#1616](https://github.com/yesodweb/persistent/pull/1616) + * Allow overriding the default cascade option for foreign keys. +* [#1608](https://github.com/yesodweb/persistent/pull/1608) + * Improves documentation on getBy with nullable fields + * Updates the warning text present when you try to make a Unique field that is nullable -* Backported the fix from [#1207](https://github.com/yesodweb/persistent/pull/1207) for asynchronous exceptions. - * Deprecated the `Acquire` family of functions. +# 2.18.0.0 -## 2.10.5.3 +* [#1610](https://github.com/yesodweb/persistent/pull/1610) + * Added `NoAction` as a `CascadeAction` -* Backported the fix from [#1135](https://github.com/yesodweb/persistent/pull/1135) to the 2.10 branch. - This should fix reading `PersistUTCTime` values. +# 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) + * Add `tabulateEntityApply` to `PersistEntity` class similar to + `tabulateEntityA` but that works on `Apply` type instead of `Applicative`. + This allows you to use `foldMap1` and other non-empty structures with + tabulating and manipulating records. + +# 2.16.0.0 + +* [#1584](https://github.com/yesodweb/persistent/pull/1584) + * Rename `Span` to `SourceSpan` + * Parse entity definitions using Megaparsec. + * Support Haddock-style multiline pre-comments. +* [#1589](https://github.com/yesodweb/persistent/pull/1589) + * Support configurable parse errors and warnings +* [#1585](https://github.com/yesodweb/persistent/pull/1585) + * Support parsing PersistField UTCTime from text with timezone, e.g. "2025-04-12T06:53:42Z". + This is needed for Sqlite, which has no native datetime support but uses e.g. TEXT. +* [#1587](https://github.com/yesodweb/persistent/pull/1587) + * Improve documentation of `mpsFieldLabelModifier`. + +# 2.15.1.0 + +* [#1519](https://github.com/yesodweb/persistent/pull/1519/files/9865a295f4545d30e55aacb6efc25f27f758e8ad#diff-5af2883367baae8f7f266df6a89fc2d1defb7572d94ed069e05c8135a883bc45) + * Add `keyAndEntityFieldsDatabase`. This was intended to be added in 2.14.7.0 but was not properly re-exported. + +# 2.15.0.1 + +* [#1575](https://github.com/yesodweb/persistent/pull/1575) + * Fix benchmark build for GHC 9.8-9.12 + * Support `template-haskell` up to 2.24 + +# 2.15.0.0 + +* [#1569](https://github.com/yesodweb/persistent/pull/1569) + * Add position information to `EntityDef`, `UnboundEntityDef` via a `Span` + field as a preliminary design that just gives the entire span of the + input text (i.e. the entire file or quasiquote the item is defined in). + * Move `Database.Persist.TH` internals to `Database.Persist.TH.Internal` and + no longer export the following internals: + * lensPTH + * parseReferences + * embedEntityDefs + * fieldError + * AtLeastOneUniqueKey(..) + * OnlyOneUniqueKey(..) + * pkNewtype + +## 2.14.6.3 + +* [#1544](https://github.com/yesodweb/persistent/pull/1544) + * Fix type error message when no unique keys are defined on a model and you + use a function with constraint `AtLeastOneUniqueKey`. + +## 2.14.6.2 + +* [#1536](https://github.com/yesodweb/persistent/pull/1536/) + * Build with GHC 9.10 + +## 2.14.6.1 + +* [#1528](https://github.com/yesodweb/persistent/pull/1528) + * The `PersistField Int{,8,16,32,64}` instances will now work with a + `PersistRational`, provided that the denominator is 1. This fixes the bug + where `SUM` in Postgres would change the type of a column being summed. + +## 2.14.6.0 + +* [#1477](https://github.com/yesodweb/persistent/pull/1477) + * Qualified references to other tables will work +* [#1503](https://github.com/yesodweb/persistent/pull/1503) + * Create Haddocks from entity documentation comments +* [1497](https://github.com/yesodweb/persistent/pull/1497) + * Always generates `SymbolToField "id"` instance +* [#1509](https://github.com/yesodweb/persistent/pull/1509) + * Provide `ViaPersistEntity` for defining `PathMultiPiece` for entity keys. +* [#1480](https://github.com/yesodweb/persistent/pull/1480) + * Add `mpsAvoidHsKeyword` in `MkPersistSettings` + * +## 2.14.5.2 + +* [#1513](https://github.com/yesodweb/persistent/pull/1513) + * Support GHC 9.8 and `aeson-2.2` + +## 2.14.5.1 + +* [#1496](https://github.com/yesodweb/persistent/pull/1496) + * Fixes name shadowing error at the generated `keyFromRecordM` function. +* [#1505](https://github.com/yesodweb/persistent/pull/1505) + * Fixes the comment line parsing rule so that accommodates paragraph breaks. + +## 2.14.5.0 + +* [#1469](https://github.com/yesodweb/persistent/pull/1469) + * Change default implementation for `insertUnique_` to not perform + unecessary queries (mirrors 1449) +* [#1437](https://github.com/yesodweb/persistent/pull/1437) + * Add `existsBy` to `PersistUniqueRead` + +## 2.14.4.5 + +* [#1460](https://github.com/yesodweb/persistent/pull/1468) + * Remove extraneous `map toPersistValue` call in the `mkInsertValues` + function, as it evaluates to `id`. +* [#1476](https://github.com/yesodweb/persistent/pull/1476) + * Fix `mkRecordName` to suffix `_` if the field name matches any of Haskell keywords. + +## 2.14.4.4 + +* [#1460](https://github.com/yesodweb/persistent/pull/1460) + * Fix a problem where a `Primary` key causes `mkPersist` to generate code + that doesn't compile under `NoFieldSelectors` + +## 2.14.4.3 + +* [#1452](https://github.com/yesodweb/persistent/pull/1452) + * Implement `repsert` as a special case of `respertMany`. Allows backend + specific behavior. + +## 2.14.4.2 + +* [#1451](https://github.com/yesodweb/persistent/pull/1451) + * Support `mtl >= 2.3` + +## 2.14.4.1 + +* [#1449](https://github.com/yesodweb/persistent/pull/1449) + * Default implementation for `insert_` which doesn't perform any unnecessary + queries. + +## 2.14.4.0 + +* [#1440](https://github.com/yesodweb/persistent/pull/1440) + * Defined NFData PersistValue + +## 2.14.3.2 + +* [#1446](https://github.com/yesodweb/persistent/pull/1446) + * Foreign key discovery was fixed for qualified names, `Key Model`, and + `Maybe` references. +* [#1438](https://github.com/yesodweb/persistent/pull/1438) + * Clarify wording on the error message for null in unique constraint +* [#1447](https://github.com/yesodweb/persistent/pull/1447) + * Fix `SafeToInsert` not being generated correctly for some `Id` columns + +## 2.14.3.1 + +* [#1428](https://github.com/yesodweb/persistent/pull/1428) + * Fix that the documentation for `discoverEntities` was not being generated. + +## 2.14.3.0 + +* [#1425](https://github.com/yesodweb/persistent/pull/1425) + * Introduce an alias `setPsUseSnakeCaseForeignKeys` for + `setPsUseSnakeCaseForiegnKeys` due to a typo in the latter; + deprecate `setPsUseSnakeCaseForiegnKeys` + +## 2.14.2.0 + +* [#1421](https://github.com/yesodweb/persistent/pull/1421) + * Add `mpsCamelCaseCompositeKeySelector` field to `MkPersistSettings`, + which define the style of the entity's composite key. + +## 2.14.1.0 + +* [#1418](https://github.com/yesodweb/persistent/pull/1418/) + * Re-export `SafeToInsert` from `Database.Persist.Class`, which should + re-export it through `Database.Persist`, `Database.Persist.Sql`, etc. +* [#1409](https://github.com/yesodweb/persistent/pull/1409) + * Fix incorrect reference to rawSql in documentation. + +## 2.14.0.3 + +* [#1411](https://github.com/yesodweb/persistent/pull/1411) + * Fix the docs for `FieldNameDB`, and update `FieldDef.fieldComments` docs + since the quasiquoter *supports* field comments now. + +## 2.14.0.2 + +* [#1407](https://github.com/yesodweb/persistent/pull/1407) + * Fix a name shadowing warning. + +## 2.14.0.1 + +* [#1392](https://github.com/yesodweb/persistent/pull/1392) + * Enhance `selectList` documentation with TypeApplications examples. + * Clarify `selectSource` documentation wording. +* [#1391](https://github.com/yesodweb/persistent/pull/1391) + * Increasing quasi module test coverage, improve error assertions +* [#1401](https://github.com/yesodweb/persistent/pull/1401) + * Change `Entity` back into a regular record and drop the `HasField` + instance. This is technically a breaking change, but [the bug in GHC's + `COMPLETE` annotations](https://gitlab.haskell.org/ghc/ghc/-/issues/15681) + rendered a super common pattern a much more invasive breaking change than + anticipated. As a result, upgrading to `persistent-2.14` was untenable. + + If you *did* upgrade and this broke your codebase *again*, please let me + know and I can release another patch to shim it. + +## 2.14.0.0 + +* [#1343](https://github.com/yesodweb/persistent/pull/1343) + * Implement Type Literal based field definitions +* [#1387](https://github.com/yesodweb/persistent/pull/1387) + * Better UX with `insert`. We now report a type error when you try to + `insert` an `Entity` or a function, and we also forbid `insert`ing if the + database would throw an error missing a primary key. +* [#1383](https://github.com/yesodweb/persistent/pull/1383) + * Primary keys have a `NonEmpty` of fields, not a `[]` of fields. + * A `Primary` key on an entity now creates a `Unique` constructror for that + record, with the name `#{entityName}PrimaryKey`. This also affects the + generation of `AtLeastOneUniqueKey` and `OnlyOneUniqueKey` instances, so + you may need to change behavior on these classes. +* [#1381](https://github.com/yesodweb/persistent/pull/1381) + * `Entity` is given a `HasField` instance that uses the database field + names. This is primarily done to support `OverloadedRecordDot` in GHC 9.2 + and above. + * A consequence of this is that the `Entity` constructor has been renamed to + `Entity'`. A pattern synonym is provided that should work in almost all + cases. You may incur a `MonadFail m` constraint if you are pattern + matching directly on the constructor in a `do` result. +* [#1364](https://github.com/yesodweb/persistent/pull/1346) + * The type `SomePersistField` was removed in favor of using `PersistValue` + directly. +* [#1386](https://github.com/yesodweb/persistent/pull/1386) + * The module `Database.Persist.Class.DeleteCascade` was deleted since you + can put cascade behavior directly on your database models. + * Removed `mkSave` from `Database.Persist.TH`. Use `mkEntityDefList` + instead. + * Remove the `CompositeDef` constructor from `ReferenceDef` which was not + used internally anymore. +* [#1385](https://github.com/yesodweb/persistent/pull/1385) + * The support for entity-level sum types is deprecated. It adds a + considerable amount of complexity to the code, and the pattern is not + particularly good for actually supporting sum types in most databases. +* [#1384](https://github.com/yesodweb/persistent/pull/1384) + * Add `tabulateEntityA` to the `PersistEntity` class, allowing you to + construct an `Entity a` by providing a function `EntityField a t -> f t`. + Note that this doesn't make sense for sum entities, and the implementation + `error`s. + * Add `tabulateEntity` as a pure version of that. + +## 2.13.3.5 + +* [#1374](https://github.com/yesodweb/persistent/pull/1374) + * Increasing test coverage for errors thrown when parsing entity definitions + +## 2.13.3.4 +* [#1379](https://github.com/yesodweb/persistent/pull/1379) + * `mkPersist` now generates code that compiles under `NoFieldSelectors` and `DuplicateRecordFields` even if field labels are not prefixed +* [#1376](https://github.com/yesodweb/persistent/pull/1376) + * Add coverage for parsing nested parens/lists in field types +* [#1370](https://github.com/yesodweb/persistent/pull/1370) + * Add spec to assert Persistent.TH is the only import required when defining entities + +## 2.13.3.3 + +* [#1369](https://github.com/yesodweb/persistent/pull/1369) + * Fix `withObject` needing to be imported + +## 2.13.3.2 + +* [#1315](https://github.com/yesodweb/persistent/pull/1315) + * Refactor entity constraint parsing in Quasi module + +## 2.13.3.1 + +* [#1367](https://github.com/yesodweb/persistent/pull/1367), + [#1366](https://github.com/yesodweb/persistent/pull/1367), + [#1338](https://github.com/yesodweb/persistent/pull/1338), + [#1335](https://github.com/yesodweb/persistent/pull/1335) + * Support GHC 9.2 +* [#1356](https://github.com/yesodweb/persistent/pull/1356) + * Improve parse errors in generated FromJSON instances + +## 2.13.3.0 + +* [#1341](https://github.com/yesodweb/persistent/pull/1341) + * Add `SqlBackendHooks` to allow for instrumentation of queries. +* [#1327](https://github.com/yesodweb/persistent/pull/1327) + * Update `SqlBackend` to use new `StatementCache` interface + instead of `IORef (Map Text Statement)` + +## 2.13.2.2 + +* [#1351](https://github.com/yesodweb/persistent/pull/1351/) + * `aeson-2.0` support + +## 2.13.2.1 + +* [#1329](https://github.com/yesodweb/persistent/pull/1329) + * Prevent discovery of constrained `PersistEntity` instances in + `discoverEntities` (since the discovered instances won't work without + constraints anyway). + +## 2.13.2.0 + +* [#1314](https://github.com/yesodweb/persistent/pull/1314) + * Fix typos and minor documentation issues in Database.Persist and + Database.Persist.Quasi. +* [#1317](https://github.com/yesodweb/persistent/pull/1317) + * Expose `orderClause` from the Persistent internals, which allows users + to produce well-formatted `ORDER BY` clauses. + +* [#1319](https://github.com/yesodweb/persistent/pull/1319) + * Add a `Num` instance for `OverflowNatural` + +## 2.13.1.2 + +* [#1308](https://github.com/yesodweb/persistent/pull/1308) + * Consolidate the documentation for the Persistent quasiquoter in + Database.Persist.Quasi. +* [#1312](https://github.com/yesodweb/persistent/pull/1312) + * Reorganize documentation and link to more modules. + * Expose `Database.Persist.Sql.Migration` + +## 2.13.1.1 + +* [#1294](https://github.com/yesodweb/persistent/pull/1294) + * Fix an issue where documentation comments on fields are in reverse line + order. + +## 2.13.1.0 + +* [#1264](https://github.com/yesodweb/persistent/pull/1264) + * Support declaring Maybe before the type in model definitions + +## 2.13.0.4 + +* [#1277](https://github.com/yesodweb/persistent/pull/1277) + * Corrected the documentation of `addMigration` to match the actual + behaviour - this will not change the behaviour of your code. + +## 2.13.0.3 + +* [#1287](https://github.com/yesodweb/persistent/pull/1287) + * Fix the duplicate entity check for transitive dependencies. + * Fixes an issue where generating code would refer to the `ModelName` when + making a reference to another table when the explicit code only refers to + `ModelNameId`. + +## 2.13.0.2 + +* [#1265](https://github.com/yesodweb/persistent/pull/1265) + * Support GHC 9 + +## 2.13.0.1 + +* [#1268](https://github.com/yesodweb/persistent/pull/1268) + * Show `keyFromValues` error + +## 2.13.0.0 + +* [#1244](https://github.com/yesodweb/persistent/pull/1244) + * Implement config for customising the FK name +* [#1252](https://github.com/yesodweb/persistent/pull/1252) + * `mkMigrate` now defers to `mkEntityDefList` and `migrateModels` instead of + fixing the foreign key references itself. + * `mkSave` was deprecated - the function did not fix foreign key references. + Please use `mkEntityDefList` instead. + * `EntityDef` will now include fields marked `MigrationOnly` and + `SafeToRemove`. Beforehand, those were filtered out, and `mkMigrate` + applied. The function `getEntityFields` will only return fields defined on + the Haskell type - for all columns, see `getEntityFieldsDatabase`. +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * The fields and constructor for `SqlBackend` are no longer exported by + default. They are available from an internal module, + `Database.Persist.Sql.Types.Internal`. Breaking changes from `Internal` + modules are not reflected in the major version. This will allow us to + release new functionality without breaking your code. It's recommended to + switch to using the smart constructor functions and setter functions that + are now exported from `Database.Persist.Sql` instead. + * A new API is available for constructing and using a `SqlBackend`, provided + in `Database.Persist.SqlBackend`. Instead of using the `SqlBackend` + directly, use `mkSqlBackend` and the datatype `MkSqlBackendArgs`. The + `MkSqlBackendArgs` record has the same field names as the `SqlBackend`, so + the translation is easy: + + ```diff + - SqlBackend + + mkSqlBackend MkSqlBackendArgs + { connInsertSql = ... + , connCommit = ... + , connEscapeFieldName = ... + , connEscapeTableName = ... + , etc + } + ``` + + Some fields were omitted in `MkSqlBackendArgs`. These fields are + *optional* - they provide enhanced or backend-specific functionality. For + these, use the setter functions like `setConnUpsertSql`. + * Previously hidden modules are now exposed under the `Internal` namespace. + * The `connLimitOffset` function used to have a `Bool` parameter. This + parameter is unused and has been removed. +* [#1234](https://github.com/yesodweb/persistent/pull/1234) + * You can now customize the default implied ID column. See the documentation + in `Database.Persist.ImplicitIdDef` for more details. + * Moved the various `Name` types into `Database.Persist.Names` + * Removed the `hasCompositeKey` function. See `hasCompositePrimaryKey` and + `hasNaturalKey` as replacements. + * The `EntityDef` constructor and field labels are not exported by default. + Get those from `Database.Persist.EntityDef.Internal`, but you should + migrate to the getters/setters in `Database.Persist.EntityDef` as you can. + * Added the `Database.Persist.FieldDef` and + `Database.Persist.FieldDef.Internal` modules. + * The `PersistSettings` type was made abstract. Please migrate to the + getters/setters defined in that `Database.Persist.Quasi`, or use + `Database.Persist.Quasi.Internal` if you don't mind the possibility of + breaking changes. + * Add the `runSqlCommand` function for running arbitrary SQL during + migrations. + * Add `migrateModels` function for a TH-free migration facility. +* [#1253](https://github.com/yesodweb/persistent/pull/1253) + * Add `discoverEntities` to discover instances of the class and return their + entity definitions. +* [#1250](https://github.com/yesodweb/persistent/pull/1250) + * The `mpsGeneric` function has been deprecated. If you need this + functionality, please comment with your needs on the GitHub issue tracker. + We may un-deprecate it, or we may provide a new and better means of + facilitating a solution to your problem. +* [#1255](https://github.com/yesodweb/persistent/pull/1255) + * `mkPersist` now checks to see if an instance already exists for + `PersistEntity` for the inputs. +* [#1256](https://github.com/yesodweb/persistent/pull/1256) + * The QuasiQuoter has been refactored and improved. + * You can now use `mkPersistWith` to pass in a list of pre-existing + `EntityDef` to improve foreign key detection and splitting up models + across multiple modules. + * The `entityId` field now returns an `EntityIdDef`, which specifies what + the ID field actually is. This is a move to better support natural keys. + * Several types that had lists have been refactored to use nonempty lists to + better capture the semantics. + * `mkDeleteCascade` is deprecated. Please use the Cascade behavior directly + on fields. + * You can use `Key Foo` and `FooId` interchangeably in fields. + * Support for GHC < 8.4 dropped. + +## 2.12.1.2 + +* [#1258](https://github.com/yesodweb/persistent/pull/1258) + * Support promoted types in Quasi Quoter +* [#1243](https://github.com/yesodweb/persistent/pull/1243) + * Assorted cleanup of TH module +* [#1242](https://github.com/yesodweb/persistent/pull/1242) + * Refactor setEmbedField to use do notation +* [#1237](https://github.com/yesodweb/persistent/pull/1237) + * Remove nonEmptyOrFail function from recent tests + +## 2.12.1.1 + +* [#1231](https://github.com/yesodweb/persistent/pull/1231) + * Simplify Line type in Quasi module, always use NonEmpty +* [#1229](https://github.com/yesodweb/persistent/pull/1229) + * The `#id` labels are now generated for entities. + +## 2.12.1.0 + +* [#1218](https://github.com/yesodweb/persistent/pull/1218) + * Refactoring name generating functions in TH +* [#1226](https://github.com/yesodweb/persistent/pull/1226) + * Expose the `filterClause` and `filterClauseWithValues` functions to support + the `upsertWhere` functionality in `persistent-postgresql`. + +## 2.12.0.2 + +* [#1123](https://github.com/yesodweb/persistent/pull/1223) + * Fix JSON encoding for `PersistValue` + +## 2.12.0.1 + +* Refactoring token parsing in quasi module [#1206](https://github.com/yesodweb/persistent/pull/1206) +* Removing duplication from TH output [#1202](https://github.com/yesodweb/persistent/pull/1202) +* Refactor [] to NonEmpty in Quasi module [#1193](https://github.com/yesodweb/persistent/pull/1193) +* [#1162](https://github.com/yesodweb/persistent/pull/1162) + * Replace `askLogFunc` with `askLoggerIO` +* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) +* Use `resourcet-pool` to break out some `Data.Pool` logic [#1163](https://github.com/yesodweb/persistent/pull/1163) +* [#1178](https://github.com/yesodweb/persistent/pull/1178) + * Added 'withBaseBackend', 'withCompatible' to ease use of base/compatible backend queries in external code. +* Added GHC 8.2.2 and GHC 8.4.4 back into the CI and `persistent` builds on 8.2.2 again [#1181](https://github.com/yesodweb/persistent/issues/1181) +* [#1179](https://github.com/yesodweb/persistent/pull/1179) + * Added `Compatible`, a newtype for marking a backend as compatible with another. Use it with `DerivingVia` to derive simple instances based on backend compatibility. + * Added `makeCompatibleInstances` and `makeCompatibleKeyInstances`, TemplateHaskell invocations for auto-generating standalone derivations using `Compatible` and `DerivingVia`. +* [#1207](https://github.com/yesodweb/persistent/pull/1207) + * @codygman discovered a bug in [issue #1199](https://github.com/yesodweb/persistent/issues/1199) where postgres connections were being returned to the `Pool SqlBackend` in an inconsistent state. + @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. + Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug. + Fortunately, this doesn't affect the public API, and can be a mere bug release. + * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. + For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`. +* Renaming values in persistent-template [#1203](https://github.com/yesodweb/persistent/pull/1203) +* [#1214](https://github.com/yesodweb/persistent/pull/1214): + * Absorbed the `persistent-template` package. `persistent-template` will receive a 2.12 release with a warning and a deprecation notice. + * Remove the `nooverlap` flag. It wasn't being used anymore. +* [#1205](https://github.com/yesodweb/persistent/pull/1205) + * Introduce the `PersistLiteral_` constructor, replacing the `PersistLiteral`, `PersistLiteralEscaped`, and `PersistDbSpecific`. + * The old constructors are now pattern synonyms. They don't actually differentiate between the various escaping strategies when consuming them! If you pattern match on multiple of `PersistDbSpecific`, `PersistLiteral`, or `PersistLiteralEscaped` , then you should use the `PersistLiteral_` constructor to differentiate between them. + +## 2.11.0.2 +* Fix a bug where an empty entity definition would break parsing of `EntityDef`s. [#1176](https://github.com/yesodweb/persistent/issues/1176) + +## 2.11.0.1 + +* Docs/Bugs fixes [#1153](https://github.com/yesodweb/persistent/pull/1153) + * Fix documentation on `FieldDef.fieldAttrs`. + * Postgresql backend: Add a space in cascade clause of generated SQL. + +## 2.11.0.0 + +* Foreign Key improvements [#1121](https://github.com/yesodweb/persistent/pull/1121) + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` + * It is now supported to have cascade options for simple/single-field Foreign Keys +* Introduces a breaking change to the internal function `mkColumns`, which can now be passed a record of functions to override its default behavior. [#996](https://github.com/yesodweb/persistent/pull/996) +* Added explicit `forall` notation to make most API functions play nice when using `TypeApplications`. (e.g. instead of `selectList @_ @_ @User [] []`, you can now write `selectList @User [] []`) [#1006](https://github.com/yesodweb/persistent/pull/1006) +* [#1060](https://github.com/yesodweb/persistent/pull/1060) + * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. +* [#1044](https://github.com/yesodweb/persistent/pull/1044) + * Field and constraint labels generated by TH can now be customized. + * mpsPrefixFields is deprecated in favor of using these customisation functions. +* [#1032](https://github.com/yesodweb/persistent/pull/1032) + * Instance for `Natural` is removed. See `OverflowNatural` for a + replacement and rationale on why. +* [#1063](https://github.com/yesodweb/persistent/pull/1063) + * A new class member `keyFromRecordM` allows you to construct a `Key + record` from a `record` if it was defined with `Primary`. +* [#1036](https://github.com/yesodweb/persistent/pull/1036) + * The method `entityIdFromJSON` that is used to parse entities now correctly works for entities that define a custom `Primary` key. +* [#856](https://github.com/yesodweb/persistent/pull/856) + * Modify `upsertBy` to use backend-specific implementation (if any). +* [#1066](https://github.com/yesodweb/persistent/pull/1066) + * You can set a column's `sql=id` for a non `Id` column. +* Fix a bug where unsafe migration error messages were being shown using `Show` prior to printing, resulting in less helpful output. [#1080](https://github.com/yesodweb/persistent/pull/1080) +* [#1087](https://github.com/yesodweb/persistent/pull/1087) + * `RawSql` now has tuple instances up to GHC's max tuple size (62) +* [#1076](https://github.com/yesodweb/persistent/pull/1076) + * `Loc` is now imported from `monad-logger` as opposed to `template-haskell`. Removes `template-haskell` as an explicit dependency. +* [#1114](https://github.com/yesodweb/persistent/pull/1114) + * Remove unnecessary deriving of `Typeable`. +* [#1128](https://github.com/yesodweb/persistent/pull/1128) + * Remove `Monad` constraint on `entityDef` +* [#1127](https://github.com/yesodweb/persistent/pull/1127) + * Remove deriving of `Show` for uniques. Users that need a `Show` instance can put a standalone deriving instance: + + ```haskell + deriving stock instance Show (Unique User) + ``` + +* [#1131](https://github.com/yesodweb/persistent/pull/1131) + * Add an `exists` function to the `PersistQueryRead` type class. +* [#1117](https://github.com/yesodweb/persistent/issues/1117) + * Allow parsing UTCTimes from sqlite with the format "%F %T%Q" as well, instead of only "%FT%T%Q". +* [#1140](https://github.com/yesodweb/persistent/pull/1140) + * A new function `checkUniqueUpdateable` allows you to check uniqueness + constraints on an entity update without having to update it. +* [#1142](https://github.com/yesodweb/persistent/pull/1142) + * Deprecate `hasCompositeKey` in favor of `hasCustomPrimaryKey` and `hasCompositePrimaryKey` functions. +* [#1098](https://github.com/yesodweb/persistent/pull/1098) + * Add support for configuring the number of stripes and idle timeout for connection pools + * For functions that do not specify an idle timeout, the default has been bumped to 600 seconds. + * This change is based off the experience of two production codebases. See [#775](https://github.com/yesodweb/persistent/issues/775) + * Add a new type `ConnectionPoolConfig` to configure the number of connections in a pool, their idle timeout, and stripe size. + * Add `defaultConnectionPoolConfig` to create a `ConnectionPoolConfig` + * Add `createSqlPoolWithConfig` and `withSqlPoolWithConfig`, which take this new data type +* [#1122](https://github.com/yesodweb/persistent/pull/1122), [#1152](https://github.com/yesodweb/persistent/pull/1152) + * Adds a new constructor, `PersistLiteral ByteString` to `PersistValue` to support unescaped SQL literals. + * Obviously, this is highly unsafe, and you should never use it with user input. + * Adds a new field, `cGenerated :: Maybe Text` to `Column` for backend-specific support of generated columns. + * Express generated fields in the Persistent DSL + + ```haskell + GeneratedColumnExample + fieldOne Text Maybe + fieldTwo Text Maybe + fieldThree Text Maybe generated=COALESCE(field_one,field_two) + ``` + + * Support for MySQL >= 5.7. (No version checking is performed! Using this feature with older versions of MySQL will cause runtime SQL exceptions!) + * Support for Postgresql >= 12. (No version checking is performed! Using this feature with older versions of Postgresql will cause runtime SQL exceptions!) + * Support for SQLite >= 3.31 (same caveat applies; support added in #1152 ) +* [#1151](https://github.com/yesodweb/persistent/pull/1151) + * Allow `OverloadedLabels` to be used with the `EntityField` type. + ## 2.10.5.2 * [#1041](https://github.com/yesodweb/persistent/pull/1041) @@ -19,7 +613,7 @@ ## 2.10.5.1 * [#1024](https://github.com/yesodweb/persistent/pull/1024) - * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. + * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi` ## 2.10.5 diff --git a/Database/Persist.hs b/Database/Persist.hs --- a/Database/Persist.hs +++ b/Database/Persist.hs @@ -1,38 +1,114 @@ {-# LANGUAGE ExistentialQuantification #-} + +-- | Welcome to @persistent@! +-- +-- This library intends to provide an easy, flexible, and convenient interface +-- to various data storage backends. Backends include SQL databases, like +-- @mysql@, @postgresql@, and @sqlite@, as well as NoSQL databases, like +-- @mongodb@ and @redis@. +-- +-- If you intend on using a SQL database, then check out "Database.Persist.Sql". module Database.Persist - ( module Database.Persist.Class - , module Database.Persist.Types + ( -- * Defining Database Models - -- * Reference Schema & Dataset - -- | -- - -- All the combinators present here will be explained based on this schema: - -- - -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - -- > User - -- > name String - -- > age Int - -- > deriving Show - -- > |] - -- - -- and this dataset. The examples below will refer to this as dataset-1. - -- - -- #dataset# + + -- | @persistent@ lets you define your database models using a special syntax. + -- This syntax allows you to customize the resulting Haskell datatypes and + -- database schema. See "Database.Persist.Quasi" for details on that definition + -- language. + + -- ** Reference Schema & Dataset + -- - -- > +-----+-----+-----+ - -- > |id |name |age | - -- > +-----+-----+-----+ - -- > |1 |SPJ |40 | - -- > +-----+-----+-----+ - -- > |2 |Simon|41 | - -- > +-----+-----+-----+ - -- * Query update combinators - , (=.), (+=.), (-=.), (*=.), (/=.) + -- | For a quick example of the syntax, we'll introduce this database schema, and + -- we'll use it to explain the update and filter combinators. + -- + -- @ + -- 'share' ['mkPersist' 'sqlSettings', 'mkMigrate' "migrateAll"] ['persistLowerCase'| + -- User + -- name String + -- age Int + -- deriving Show + -- |] + -- @ + -- + -- This creates a Haskell datatype that looks like this: + -- + -- @ + -- data User = User + -- { userName :: String + -- , userAge :: Int + -- } + -- deriving Show + -- @ + -- + -- In a SQL database, we'd get a migration like this: + -- + -- @ + -- CREATE TABLE "user" ( + -- id SERIAL PRIMARY KEY, + -- name TEXT NOT NULL, + -- age INT NOT NULL + -- ); + -- @ + -- + -- The examples below will refer to this as dataset-1. + -- + -- #dataset# + -- + -- > +-----+-----+-----+ + -- > |id |name |age | + -- > +-----+-----+-----+ + -- > |1 |SPJ |40 | + -- > +-----+-----+-----+ + -- > |2 |Simon|41 | + -- > +-----+-----+-----+ - -- * Query filter combinators - , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.) + -- * Database Operations + -- | The module "Database.Persist.Class" defines how to operate with + -- @persistent@ database models. Check that module out for basic + -- operations, like 'get', 'insert', and 'selectList'. + module Database.Persist.Class + + -- * Types + + -- | This module re-export contains a lot of the important types for + -- working with @persistent@ datatypes and underlying values. + , module Database.Persist.Types + + -- * Query Operators + + -- | A convention that @persistent@ tries to follow is that operators on + -- Database types correspond to a Haskell (or database) operator with a @.@ + -- character at the end. So to do @a || b@ , you'd write @a '||.' b@. To + + -- ** Query update combinators + + -- | These operations are used when performing updates against the database. + -- Functions like 'upsert' use them to provide new or modified values. + , (=.) + , (+=.) + , (-=.) + , (*=.) + , (/=.) + + -- ** Query filter combinators + + -- | These functions are useful in the 'PersistQuery' class, like + -- 'selectList', 'updateWhere', etc. + , (==.) + , (!=.) + , (<.) + , (>.) + , (<=.) + , (>=.) + , (<-.) + , (/<-.) + , (||.) + -- * JSON Utilities , listToJSON , mapToJSON @@ -43,23 +119,27 @@ , limitOffsetOrder ) where -import Data.Aeson (toJSON, ToJSON) +import Data.Aeson (ToJSON, toJSON) import Data.Aeson.Text (encodeToTextBuilder) import qualified Data.Text as T import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) -import Database.Persist.Types import Database.Persist.Class import Database.Persist.Class.PersistField (getPersistMap) +import Database.Persist.Types infixr 3 =., +=., -=., *=., /=. -(=.), (+=.), (-=.), (*=.), (/=.) :: - forall v typ. PersistField typ => EntityField v typ -> typ -> Update v +(=.) + , (+=.) + , (-=.) + , (*=.) + , (/=.) + :: forall v typ. (PersistField typ) => EntityField v typ -> typ -> Update v -- | Assign a field a value. -- --- === __Example usage__ +-- === Examples -- -- @ -- updateAge :: MonadIO m => ReaderT SqlBackend m () @@ -77,12 +157,11 @@ -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ - f =. a = Update f a Assign -- | Assign a field by addition (@+=@). -- --- === __Example usage__ +-- === Examples -- -- @ -- addAge :: MonadIO m => ReaderT SqlBackend m () @@ -98,13 +177,11 @@ -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ - - f +=. a = Update f a Add -- | Assign a field by subtraction (@-=@). -- --- === __Example usage__ +-- === Examples -- -- @ -- subtractAge :: MonadIO m => ReaderT SqlBackend m () @@ -120,12 +197,11 @@ -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ - f -=. a = Update f a Subtract -- | Assign a field by multiplication (@*=@). -- --- === __Example usage__ +-- === Examples -- -- @ -- multiplyAge :: MonadIO m => ReaderT SqlBackend m () @@ -141,13 +217,11 @@ -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ - - f *=. a = Update f a Multiply -- | Assign a field by division (@/=@). -- --- === __Example usage__ +-- === Examples -- -- @ -- divideAge :: MonadIO m => ReaderT SqlBackend m () @@ -163,16 +237,20 @@ -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ - f /=. a = Update f a Divide infix 4 ==., <., <=., >., >=., !=. -(==.), (!=.), (<.), (<=.), (>.), (>=.) :: - forall v typ. PersistField typ => EntityField v typ -> typ -> Filter v +(==.) + , (!=.) + , (<.) + , (<=.) + , (>.) + , (>=.) + :: forall v typ. (PersistField typ) => EntityField v typ -> typ -> Filter v -- | Check for equality. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectSPJ :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -186,12 +264,11 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ - -f ==. a = Filter f (FilterValue a) Eq +f ==. a = Filter f (FilterValue a) Eq -- | Non-equality check. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectSimon :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -205,12 +282,11 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ - f !=. a = Filter f (FilterValue a) Ne -- | Less-than check. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectLessAge :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -224,12 +300,11 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ - -f <. a = Filter f (FilterValue a) Lt +f <. a = Filter f (FilterValue a) Lt -- | Less-than or equal check. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectLessEqualAge :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -243,12 +318,11 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ - -f <=. a = Filter f (FilterValue a) Le +f <=. a = Filter f (FilterValue a) Le -- | Greater-than check. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectGreaterAge :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -262,12 +336,11 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ - -f >. a = Filter f (FilterValue a) Gt +f >. a = Filter f (FilterValue a) Gt -- | Greater-than or equal check. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectGreaterEqualAge :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -281,15 +354,16 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ - -f >=. a = Filter f (FilterValue a) Ge +f >=. a = Filter f (FilterValue a) Ge infix 4 <-., /<-. -(<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v +(<-.) + , (/<-.) + :: forall v typ. (PersistField typ) => EntityField v typ -> [typ] -> Filter v -- | Check if value is in given list. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectUsers :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -319,12 +393,11 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ - f <-. a = Filter f (FilterValues a) In -- | Check if value is not in given list. -- --- === __Example usage__ +-- === Examples -- -- @ -- selectSimon :: MonadIO m => ReaderT SqlBackend m [Entity User] @@ -338,7 +411,6 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ - f /<-. a = Filter f (FilterValues a) NotIn infixl 3 ||. @@ -369,7 +441,7 @@ -- -- will filter records where a person's age is between 25 and 30 /and/ -- (person's category is either 1 or 5). -a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] +a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] -- | Convert list of 'PersistValue's into textual representation of JSON -- object. This is a type-constrained synonym for 'toJsonText'. @@ -383,16 +455,17 @@ -- | A more general way to convert instances of `ToJSON` type class to -- strict text 'T.Text'. -toJsonText :: ToJSON j => j -> T.Text +toJsonText :: (ToJSON j) => j -> T.Text toJsonText = toStrict . toLazyText . encodeToTextBuilder . toJSON -- | FIXME What's this exactly? -limitOffsetOrder :: PersistEntity val - => [SelectOpt val] - -> (Int, Int, [SelectOpt val]) +limitOffsetOrder + :: (PersistEntity val) + => [SelectOpt val] + -> (Int, Int, [SelectOpt val]) limitOffsetOrder opts = foldr go (0, 0, []) opts where - go (LimitTo l) (_, b, c) = (l, b ,c) + go (LimitTo l) (_, b, c) = (l, b, c) go (OffsetBy o) (a, _, c) = (a, o, c) go x (a, b, c) = (a, b, x : c) diff --git a/Database/Persist/Class.hs b/Database/Persist/Class.hs --- a/Database/Persist/Class.hs +++ b/Database/Persist/Class.hs @@ -1,37 +1,47 @@ {-# LANGUAGE ConstraintKinds #-} -module Database.Persist.Class - ( ToBackendKey (..) - -- * PersistStore - -- | - -- - -- All the examples present here will be explained based on these schemas, datasets and functions: - -- - -- = schema-1 - -- - -- #schema-persist-store-1# - -- - -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - -- > User - -- > name String - -- > age Int - -- > deriving Show - -- > |] - -- - -- = dataset-1 - -- - -- #dataset-persist-store-1# - -- - -- > +----+-------+-----+ - -- > | id | name | age | - -- > +----+-------+-----+ - -- > | 1 | SPJ | 40 | - -- > +----+-------+-----+ - -- > | 2 | Simon | 41 | - -- > +----+-------+-----+ +-- | This module exports all of the type classes in @persistent@ for operating +-- on the database backends. +-- +-- @persistent@ offers methods that are abstract in the specific @backend@ type. +-- For SQL databases, this wil be 'Database.Persist.SqlBackend.SqlBackend'. +-- Other database backends will define their own types. +-- +-- Methods and functions in this module have examples documented under an +-- "Example Usage" thing, that you need to click on to expand. +module Database.Persist.Class + ( -- * PersistStore - , PersistCore (..) - , PersistStore + -- | The 'PersistStore', 'PersistStoreRead', and 'PersistStoreWrite' type + -- classes are used to define basic operations on the database. A database + -- that implements these classes is capable of being used as a simple + -- key-value store. + -- + -- All the examples present here will be explained based on these schemas, datasets and functions: + -- + -- = schema-1 + -- + -- #schema-persist-store-1# + -- + -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + -- > User + -- > name String + -- > age Int + -- > deriving Show + -- > |] + -- + -- = dataset-1 + -- + -- #dataset-persist-store-1# + -- + -- > +----+-------+-----+ + -- > | id | name | age | + -- > +----+-------+-----+ + -- > | 1 | SPJ | 40 | + -- > +----+-------+-----+ + -- > | 2 | Simon | 41 | + -- > +----+-------+-----+ + PersistStore , PersistStoreRead (..) , PersistStoreWrite (..) , PersistRecordBackend @@ -40,58 +50,62 @@ , getEntity , belongsTo , belongsToJust + , SafeToInsert , insertEntity , insertRecord - -- * PersistUnique - -- | - -- - -- All the examples present here will be explained based on these two schemas and the dataset: - -- - -- = schema-1 - -- This schema has single unique constraint. - -- - -- #schema-persist-unique-1# - -- - -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - -- > User - -- > name String - -- > age Int - -- > UniqueUserName name - -- > deriving Show - -- > |] - -- - -- = schema-2 - -- This schema has two unique constraints. - -- - -- #schema-persist-unique-2# - -- - -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - -- > User - -- > name String - -- > age Int - -- > UniqueUserName name - -- > UniqueUserAge age - -- > deriving Show - -- > |] - -- - -- = dataset-1 - -- - -- #dataset-persist-unique-1# - -- - -- > +-----+-----+-----+ - -- > |id |name |age | - -- > +-----+-----+-----+ - -- > |1 |SPJ |40 | - -- > +-----+-----+-----+ - -- > |2 |Simon|41 | - -- > +-----+-----+-----+ + -- * PersistUnique + -- | The 'PersistUnique' type class is relevant for database backends that + -- offer uniqueness keys. Uniquenes keys allow us to perform operations like + -- 'getBy', 'deleteBy', as well as 'upsert' and 'putMany'. + -- + -- All the examples present here will be explained based on these two schemas and the dataset: + -- + -- = schema-1 + -- This schema has single unique constraint. + -- + -- #schema-persist-unique-1# + -- + -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + -- > User + -- > name String + -- > age Int + -- > UniqueUserName name + -- > deriving Show + -- > |] + -- + -- = schema-2 + -- This schema has two unique constraints. + -- + -- #schema-persist-unique-2# + -- + -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + -- > User + -- > name String + -- > age Int + -- > UniqueUserName name + -- > UniqueUserAge age + -- > deriving Show + -- > |] + -- + -- = dataset-1 + -- + -- #dataset-persist-unique-1# + -- + -- > +-----+-----+-----+ + -- > |id |name |age | + -- > +-----+-----+-----+ + -- > |1 |SPJ |40 | + -- > +-----+-----+-----+ + -- > |2 |Simon|41 | + -- > +-----+-----+-----+ , PersistUnique , PersistUniqueRead (..) , PersistUniqueWrite (..) , OnlyOneUniqueKey (..) , AtLeastOneUniqueKey (..) + , onlyOneUniqueDef , NoUniqueKeysError , MultipleUniqueKeysError , getByValue @@ -99,49 +113,66 @@ , insertUniqueEntity , replaceUnique , checkUnique + , checkUniqueUpdateable , onlyUnique - -- * PersistQuery + -- * PersistQuery + + -- | The 'PersistQuery' type class allows us to select lists and filter + -- database models. 'selectList' is the canonical read operation, and we + -- can write 'updateWhere' and 'deleteWhere' to modify based on filters. + , selectList + , selectKeys , PersistQuery , PersistQueryRead (..) , PersistQueryWrite (..) , selectSource - , selectKeys - , selectList , selectKeysList - -- * DeleteCascade - , DeleteCascade (..) - , deleteCascadeWhere - - -- * PersistEntity + -- * PersistEntity , PersistEntity (..) - -- * PersistField + , tabulateEntity + , SymbolToField (..) + + -- * PersistField , PersistField (..) - -- * PersistConfig + + -- * PersistConfig , PersistConfig (..) , entityValues - -- * Lifting + -- * Lifting , HasPersistBackend (..) + , withBaseBackend , IsPersistBackend () , liftPersist , BackendCompatible (..) + , withCompatibleBackend - -- * JSON utilities - , keyValueEntityToJSON, keyValueEntityFromJSON - , entityIdToJSON, entityIdFromJSON - , toPersistValueJSON, fromPersistValueJSON + -- * PersistCore + + -- | 'PersistCore' is a type class that defines a default database + -- 'BackendKey' type. For SQL databases, this is currently an + -- auto-incrementing inteer primary key. For MongoDB, it is the default + -- ObjectID. + , PersistCore (..) + , ToBackendKey (..) + + -- * JSON utilities + , keyValueEntityToJSON + , keyValueEntityFromJSON + , entityIdToJSON + , entityIdFromJSON + , toPersistValueJSON + , fromPersistValueJSON ) where -import Database.Persist.Class.DeleteCascade import Database.Persist.Class.PersistConfig import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistUnique - -- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. -- It signifies the assumption that, by default, a backend can write as well as read. diff --git a/Database/Persist/Class/DeleteCascade.hs b/Database/Persist/Class/DeleteCascade.hs deleted file mode 100644 --- a/Database/Persist/Class/DeleteCascade.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Database.Persist.Class.DeleteCascade - ( DeleteCascade (..) - , deleteCascadeWhere - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Acquire (with) - -import Database.Persist.Class.PersistStore -import Database.Persist.Class.PersistQuery -import Database.Persist.Class.PersistEntity - --- | For combinations of backends and entities that support --- cascade-deletion. “Cascade-deletion” means that entries that depend on --- other entries to be deleted will be deleted as well. -class (PersistStoreWrite backend, PersistEntity record, BaseBackend backend ~ PersistEntityBackend record) - => DeleteCascade record backend where - - -- | Perform cascade-deletion of single database - -- entry. - deleteCascade :: MonadIO m => Key record -> ReaderT backend m () - --- | Cascade-deletion of entries satisfying given filters. -deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQueryWrite backend) - => [Filter record] -> ReaderT backend m () -deleteCascadeWhere filts = do - srcRes <- selectKeysRes filts [] - conn <- ask - liftIO $ with srcRes (\src -> runConduit $ src .| CL.mapM_ (flip runReaderT conn . deleteCascade)) diff --git a/Database/Persist/Class/PersistConfig.hs b/Database/Persist/Class/PersistConfig.hs --- a/Database/Persist/Class/PersistConfig.hs +++ b/Database/Persist/Class/PersistConfig.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} + module Database.Persist.Class.PersistConfig ( PersistConfig (..) ) where @@ -5,13 +8,20 @@ import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Aeson (Value (Object)) import Data.Aeson.Types (Parser) -import qualified Data.HashMap.Strict as HashMap +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as AM +#else +import qualified Data.HashMap.Strict as AM +#endif + +import Data.Kind (Type) + -- | Represents a value containing all the configuration options for a specific -- backend. This abstraction makes it easier to write code that can easily swap -- backends. class PersistConfig c where - type PersistConfigBackend c :: (* -> *) -> * -> * + type PersistConfigBackend c :: (Type -> Type) -> Type -> Type type PersistConfigPool c -- | Load the config settings from a 'Value', most likely taken from a YAML @@ -26,26 +36,29 @@ createPoolConfig :: c -> IO (PersistConfigPool c) -- | Run a database action by taking a connection from the pool. - runPool :: MonadUnliftIO m - => c - -> PersistConfigBackend c m a - -> PersistConfigPool c - -> m a + runPool + :: (MonadUnliftIO m) + => c + -> PersistConfigBackend c m a + -> PersistConfigPool c + -> m a instance - ( PersistConfig c1 - , PersistConfig c2 - , PersistConfigPool c1 ~ PersistConfigPool c2 - , PersistConfigBackend c1 ~ PersistConfigBackend c2 - ) => PersistConfig (Either c1 c2) where + ( PersistConfig c1 + , PersistConfig c2 + , PersistConfigPool c1 ~ PersistConfigPool c2 + , PersistConfigBackend c1 ~ PersistConfigBackend c2 + ) + => PersistConfig (Either c1 c2) + where type PersistConfigBackend (Either c1 c2) = PersistConfigBackend c1 type PersistConfigPool (Either c1 c2) = PersistConfigPool c1 loadConfig (Object o) = - case HashMap.lookup "left" o of + case AM.lookup "left" o of Just v -> Left <$> loadConfig v Nothing -> - case HashMap.lookup "right" o of + case AM.lookup "right" o of Just v -> Right <$> loadConfig v Nothing -> fail "PersistConfig for Either: need either a left or right" loadConfig _ = fail "PersistConfig for Either: need an object" diff --git a/Database/Persist/Class/PersistEntity.hs b/Database/Persist/Class/PersistEntity.hs --- a/Database/Persist/Class/PersistEntity.hs +++ b/Database/Persist/Class/PersistEntity.hs @@ -1,44 +1,92 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module Database.Persist.Class.PersistEntity ( PersistEntity (..) + , tabulateEntity , Update (..) , BackendSpecificUpdate , SelectOpt (..) , Filter (..) , FilterValue (..) , BackendSpecificFilter - , Entity (..) - + , Entity (.., Entity, entityKey, entityVal) + , ViaPersistEntity (..) , recordName , entityValues - , keyValueEntityToJSON, keyValueEntityFromJSON - , entityIdToJSON, entityIdFromJSON + , keyValueEntityToJSON + , keyValueEntityFromJSON + , entityIdToJSON + , entityIdFromJSON + -- * PersistField based on other typeclasses - , toPersistValueJSON, fromPersistValueJSON - , toPersistValueEnum, fromPersistValueEnum + , toPersistValueJSON + , fromPersistValueJSON + , toPersistValueEnum + , fromPersistValueEnum + + -- * Support for @OverloadedLabels@ with 'EntityField' + , SymbolToField (..) + + -- * Safety check for inserts + , SafeToInsert + , SafeToInsertErrorMessage ) where -import Data.Aeson (ToJSON (..), FromJSON (..), fromJSON, object, (.:), (.=), Value (Object)) +import Data.Functor.Apply (Apply) +import Data.Functor.Constant + +import Data.Aeson + ( FromJSON (..) + , ToJSON (..) + , Value (Object) + , fromJSON + , object + , withObject + , (.:) + , (.=) + ) import qualified Data.Aeson.Parser as AP -import Data.Aeson.Types (Parser,Result(Error,Success)) import Data.Aeson.Text (encodeToTextBuilder) +import Data.Aeson.Types (Parser, Result (Error, Success)) import Data.Attoparsec.ByteString (parseOnly) -import qualified Data.HashMap.Strict as HM +import Data.Functor.Identity +import Web.PathPieces (PathMultiPiece (..), PathPiece (..)) + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as AM +#else +import qualified Data.HashMap.Strict as AM +#endif + +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) -import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB -import Data.Typeable (Typeable) import GHC.Generics +import GHC.OverloadedLabels +import GHC.Records +import GHC.TypeLits import Database.Persist.Class.PersistField +import Database.Persist.Names import Database.Persist.Types.Base -- | Persistent serialized Haskell records to the database. @@ -55,76 +103,205 @@ -- Some advanced type system capabilities are used to make this process -- type-safe. Persistent users usually don't need to understand the class -- associated data and functions. -class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record) - , Show (Key record), Read (Key record), Eq (Key record), Ord (Key record)) - => PersistEntity record where +class + ( PersistField (Key record) + , ToJSON (Key record) + , FromJSON (Key record) + , Show (Key record) + , Read (Key record) + , Eq (Key record) + , Ord (Key record) + ) => + PersistEntity record + where -- | Persistent allows multiple different backends (databases). type PersistEntityBackend record -- | By default, a backend will automatically generate the key -- Instead you can specify a Primary key made up of unique values. data Key record + -- | A lower-level key operation. keyToValues :: Key record -> [PersistValue] + -- | A lower-level key operation. keyFromValues :: [PersistValue] -> Either Text (Key record) + -- | A meta-operation to retrieve the 'Key' 'EntityField'. persistIdField :: EntityField record (Key record) -- | Retrieve the 'EntityDef' meta-data for the record. - entityDef :: Monad m => m record -> EntityDef + entityDef :: proxy record -> EntityDef -- | An 'EntityField' is parameterised by the Haskell record it belongs to -- and the additional type of that field. - data EntityField record :: * -> * + -- + -- As of @persistent-2.11.0.0@, it's possible to use the @OverloadedLabels@ + -- language extension to refer to 'EntityField' values polymorphically. See + -- the documentation on 'SymbolToField' for more information. + data EntityField record :: Type -> Type + -- | Return meta-data for a given 'EntityField'. persistFieldDef :: EntityField record typ -> FieldDef + -- | A meta-operation to get the database fields of a record. - toPersistFields :: record -> [SomePersistField] + toPersistFields :: record -> [PersistValue] + -- | A lower-level operation to convert from database values to a Haskell record. fromPersistValues :: [PersistValue] -> Either Text record + -- | This function allows you to build an @'Entity' a@ by specifying an + -- action that returns a value for the field in the callback function. + -- Let's look at an example. + -- + -- @ + -- parseFromEnvironmentVariables :: IO (Entity User) + -- parseFromEnvironmentVariables = + -- tabulateEntityA $ \\userField -> + -- case userField of + -- UserName -> + -- getEnv "USER_NAME" + -- UserAge -> do + -- ageVar <- getEnv "USER_AGE" + -- case readMaybe ageVar of + -- Just age -> + -- pure age + -- Nothing -> + -- error $ "Failed to parse Age from: " <> ageVar + -- UserAddressId -> do + -- addressVar <- getEnv "USER_ADDRESS_ID" + -- pure $ AddressKey addressVar + -- @ + -- + -- @since 2.14.0.0 + tabulateEntityA + :: (Applicative f) + => (forall a. EntityField record a -> f a) + -- ^ A function that builds a fragment of a record in an + -- 'Applicative' context. + -> f (Entity record) + + -- | Like 'tabulateEntityA', but works with any 'Apply' f. This works + -- because all entities have at least one field, and so we can tabulate + -- things into semigroup-like shapes instead. + -- + -- @since 2.17.0.0 + tabulateEntityApply + :: (Apply f) + => (forall a. EntityField record a -> f a) + -> f (Entity record) + -- | Unique keys besides the 'Key'. data Unique record + -- | A meta operation to retrieve all the 'Unique' keys. persistUniqueKeys :: record -> [Unique record] + -- | A lower level operation. - persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)] + persistUniqueToFieldNames + :: Unique record -> NonEmpty (FieldNameHS, FieldNameDB) + -- | A lower level operation. persistUniqueToValues :: Unique record -> [PersistValue] -- | Use a 'PersistField' as a lens. - fieldLens :: EntityField record field - -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record)) + fieldLens + :: EntityField record field + -> ( forall f + . (Functor f) => (field -> f field) -> Entity record -> f (Entity record) + ) + -- | Extract a @'Key' record@ from a @record@ value. Currently, this is + -- only defined for entities using the @Primary@ syntax for + -- natural/composite keys. In a future version of @persistent@ which + -- incorporates the ID directly into the entity, this will always be Just. + -- + -- @since 2.11.0.0 + keyFromRecordM :: Maybe (record -> Key record) + keyFromRecordM = Nothing + +-- | Newtype wrapper for optionally deriving typeclass instances on +-- 'PersistEntity' keys. +-- +-- @since 2.14.6.0 +newtype ViaPersistEntity record = ViaPersistEntity (Key record) + +instance (PersistEntity record) => PathMultiPiece (ViaPersistEntity record) where + fromPathMultiPiece pieces = do + Right key <- keyFromValues <$> mapM fromPathPiece pieces + pure $ ViaPersistEntity key + toPathMultiPiece (ViaPersistEntity key) = map toPathPiece $ keyToValues key + +-- | Construct an @'Entity' record@ by providing a value for each of the +-- record's fields. +-- +-- These constructions are equivalent: +-- +-- @ +-- entityMattConstructor, entityMattTabulate :: Entity User +-- entityMattConstructor = +-- Entity +-- { entityKey = toSqlKey 123 +-- , entityVal = +-- User +-- { userName = "Matt" +-- , userAge = 33 +-- } +-- } +-- +-- entityMattTabulate = +-- tabulateEntity $ \\case +-- UserId -> +-- toSqlKey 123 +-- UserName -> +-- "Matt" +-- UserAge -> +-- 33 +-- @ +-- +-- This is a specialization of 'tabulateEntityA', which allows you to +-- construct an 'Entity' by providing an 'Applicative' action for each +-- field instead of a regular function. +-- +-- @since 2.14.0.0 +tabulateEntity + :: (PersistEntity record) + => (forall a. EntityField record a -> a) + -> Entity record +tabulateEntity fromField = + runIdentity (tabulateEntityA (Identity . fromField)) + type family BackendSpecificUpdate backend record -- Moved over from Database.Persist.Class.PersistUnique + -- | Textual representation of the record recordName :: (PersistEntity record) => record -> Text -recordName = unHaskellName . entityHaskell . entityDef . Just +recordName = unEntityNameHS . entityHaskell . entityDef . Just -- | Updating a database entity. -- -- Persistent users use combinators to create these. -data Update record = forall typ. PersistField typ => Update - { updateField :: EntityField record typ - , updateValue :: typ - -- FIXME Replace with expr down the road - , updateUpdate :: PersistUpdate - } +data Update record + = forall typ. (PersistField typ) => Update + { updateField :: EntityField record typ + , updateValue :: typ + , -- FIXME Replace with expr down the road + updateUpdate :: PersistUpdate + } | BackendUpdate - (BackendSpecificUpdate (PersistEntityBackend record) record) + (BackendSpecificUpdate (PersistEntityBackend record) record) -- | Query options. -- -- Persistent users use these directly. -data SelectOpt record = forall typ. Asc (EntityField record typ) - | forall typ. Desc (EntityField record typ) - | OffsetBy Int - | LimitTo Int +data SelectOpt record + = forall typ. Asc (EntityField record typ) + | forall typ. Desc (EntityField record typ) + | OffsetBy Int + | LimitTo Int type family BackendSpecificFilter backend record @@ -140,23 +317,25 @@ -- 'PersistFilter' requires that you have an array- or list-shaped -- 'EntityField'. It is possible to construct values using this that will -- create malformed runtime values. -data Filter record = forall typ. PersistField typ => Filter - { filterField :: EntityField record typ - , filterValue :: FilterValue typ - , filterFilter :: PersistFilter -- FIXME - } - | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API - | FilterOr [Filter record] +data Filter record + = forall typ. (PersistField typ) => Filter + { filterField :: EntityField record typ + , filterValue :: FilterValue typ + , filterFilter :: PersistFilter -- FIXME + } + | -- | convenient for internal use, not needed for the API + FilterAnd [Filter record] + | FilterOr [Filter record] | BackendFilter - (BackendSpecificFilter (PersistEntityBackend record) record) + (BackendSpecificFilter (PersistEntityBackend record) record) -- | Value to filter with. Highly dependant on the type of filter used. -- -- @since 2.10.0 data FilterValue typ where - FilterValue :: typ -> FilterValue typ - FilterValues :: [typ] -> FilterValue typ - UnsafeValue :: forall a typ. PersistField a => a -> FilterValue typ + FilterValue :: typ -> FilterValue typ + FilterValues :: [typ] -> FilterValue typ + UnsafeValue :: forall a typ. (PersistField a) => a -> FilterValue typ -- | Datatype that represents an entity, with both its 'Key' and -- its Haskell record representation. @@ -179,8 +358,8 @@ -- migration code -- @persistent@ will expect the column to be in -- the middle, but your DBMS will put it as the last column). -- So, instead of using a query like the one above, you may use --- 'Database.Persist.GenericSql.rawSql' (from the --- "Database.Persist.GenericSql" module) with its /entity +-- 'Database.Persist.Sql.rawSql' (from the +-- "Database.Persist.Sql" module) with its /entity -- selection placeholder/ (a double question mark @??@). Using -- @rawSql@ the query above must be written as @SELECT ?? WHERE -- ..@. Then @rawSql@ will replace @??@ with the list of all @@ -188,26 +367,28 @@ -- your query returns two entities (i.e. @(Entity backend a, -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on. -data Entity record = - Entity { entityKey :: Key record - , entityVal :: record } - deriving Typeable +data Entity record + = Entity + { entityKey :: Key record + , entityVal :: record + } -deriving instance (Generic (Key record), Generic record) => Generic (Entity record) +deriving instance + (Generic (Key record), Generic record) => Generic (Entity record) deriving instance (Eq (Key record), Eq record) => Eq (Entity record) deriving instance (Ord (Key record), Ord record) => Ord (Entity record) deriving instance (Show (Key record), Show record) => Show (Entity record) deriving instance (Read (Key record), Read record) => Read (Entity record) -- | Get list of values corresponding to given entity. -entityValues :: PersistEntity record => Entity record -> [PersistValue] +entityValues :: (PersistEntity record) => Entity record -> [PersistValue] entityValues (Entity k record) = - if isJust (entityPrimary ent) - then - -- TODO: check against the key - map toPersistValue (toPersistFields record) - else - keyToValues k ++ map toPersistValue (toPersistFields record) + if isJust (entityPrimary ent) + then + -- TODO: check against the key + map toPersistValue (toPersistFields record) + else + keyToValues k ++ map toPersistValue (toPersistFields record) where ent = entityDef $ Just record @@ -220,12 +401,14 @@ -- instance ToJSON (Entity User) where -- toJSON = keyValueEntityToJSON -- @ -keyValueEntityToJSON :: (PersistEntity record, ToJSON record) - => Entity record -> Value -keyValueEntityToJSON (Entity key value) = object - [ "key" .= key - , "value" .= value - ] +keyValueEntityToJSON + :: (PersistEntity record, ToJSON record) + => Entity record -> Value +keyValueEntityToJSON (Entity key value) = + object + [ "key" .= key + , "value" .= value + ] -- | Predefined @parseJSON@. The input JSON looks like -- @{"key": 1, "value": {"name": ...}}@. @@ -236,11 +419,13 @@ -- instance FromJSON (Entity User) where -- parseJSON = keyValueEntityFromJSON -- @ -keyValueEntityFromJSON :: (PersistEntity record, FromJSON record) - => Value -> Parser (Entity record) -keyValueEntityFromJSON (Object o) = Entity - <$> o .: "key" - <*> o .: "value" +keyValueEntityFromJSON + :: (PersistEntity record, FromJSON record) + => Value -> Parser (Entity record) +keyValueEntityFromJSON (Object o) = + Entity + <$> o .: "key" + <*> o .: "value" keyValueEntityFromJSON _ = fail "keyValueEntityFromJSON: not an object" -- | Predefined @toJSON@. The resulting JSON looks like @@ -252,9 +437,10 @@ -- instance ToJSON (Entity User) where -- toJSON = entityIdToJSON -- @ -entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value +entityIdToJSON + :: (PersistEntity record, ToJSON record) => Entity record -> Value entityIdToJSON (Entity key value) = case toJSON value of - Object o -> Object $ HM.insert "id" (toJSON key) o + Object o -> Object $ AM.insert "id" (toJSON key) o x -> x -- | Predefined @parseJSON@. The input JSON looks like @@ -266,28 +452,37 @@ -- instance FromJSON (Entity User) where -- parseJSON = entityIdFromJSON -- @ -entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) -entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value -entityIdFromJSON _ = fail "entityIdFromJSON: not an object" +entityIdFromJSON + :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) +entityIdFromJSON = withObject "entityIdFromJSON" $ \o -> do + val <- parseJSON (Object o) + k <- case keyFromRecordM of + Nothing -> + o .: "id" + Just func -> + pure $ func val + pure $ Entity k val -instance (PersistEntity record, PersistField record, PersistField (Key record)) - => PersistField (Entity record) where +instance + (PersistEntity record, PersistField record, PersistField (Key record)) + => PersistField (Entity record) + where toPersistValue (Entity key value) = case toPersistValue value of (PersistMap alist) -> PersistMap ((idField, toPersistValue key) : alist) _ -> error $ T.unpack $ errMsg "expected PersistMap" fromPersistValue (PersistMap alist) = case after of - [] -> Left $ errMsg $ "did not find " `Data.Monoid.mappend` idField `mappend` " field" - ("_id", kv):afterRest -> + [] -> Left $ errMsg $ "did not find " `mappend` idField `mappend` " field" + ("_id", kv) : afterRest -> fromPersistValue (PersistMap (before ++ afterRest)) >>= \record -> keyFromValues [kv] >>= \k -> Right (Entity k record) _ -> Left $ errMsg $ "impossible id field: " `mappend` T.pack (show alist) where (before, after) = break ((== idField) . fst) alist - - fromPersistValue x = Left $ - errMsg "Expected PersistMap, received: " `mappend` T.pack (show x) + fromPersistValue x = + Left $ + errMsg "Expected PersistMap, received: " `mappend` T.pack (show x) errMsg :: Text -> Text errMsg = mappend "PersistField entity fromPersistValue: " @@ -308,7 +503,7 @@ -- fromPersistValue = fromPersistValueJSON -- toPersistValue = toPersistValueJSON -- @ -toPersistValueJSON :: ToJSON a => a -> PersistValue +toPersistValueJSON :: (ToJSON a) => a -> PersistValue toPersistValueJSON = PersistText . LT.toStrict . TB.toLazyText . encodeToTextBuilder . toJSON -- | Convenience function for getting a free 'PersistField' instance @@ -324,20 +519,23 @@ -- fromPersistValue = fromPersistValueJSON -- toPersistValue = toPersistValueJSON -- @ -fromPersistValueJSON :: FromJSON a => PersistValue -> Either Text a +fromPersistValueJSON :: (FromJSON a) => PersistValue -> Either Text a fromPersistValueJSON z = case z of - PersistByteString bs -> mapLeft (T.append "Could not parse the JSON (was a PersistByteString): ") - $ parseGo bs - PersistText t -> mapLeft (T.append "Could not parse the JSON (was PersistText): ") - $ parseGo (TE.encodeUtf8 t) - a -> Left $ T.append "Expected PersistByteString, received: " (T.pack (show a)) - where parseGo bs = mapLeft T.pack $ case parseOnly AP.value bs of - Left err -> Left err - Right v -> case fromJSON v of + PersistByteString bs -> + mapLeft (T.append "Could not parse the JSON (was a PersistByteString): ") $ + parseGo bs + PersistText t -> + mapLeft (T.append "Could not parse the JSON (was PersistText): ") $ + parseGo (TE.encodeUtf8 t) + a -> Left $ T.append "Expected PersistByteString, received: " (T.pack (show a)) + where + parseGo bs = mapLeft T.pack $ case parseOnly AP.value bs of + Left err -> Left err + Right v -> case fromJSON v of Error err -> Left err Success a -> Right a - mapLeft _ (Right a) = Right a - mapLeft f (Left b) = Left (f b) + mapLeft _ (Right a) = Right a + mapLeft f (Left b) = Left (f b) -- | Convenience function for getting a free 'PersistField' instance -- from a type with an 'Enum' instance. The function 'derivePersistField' @@ -355,7 +553,7 @@ -- fromPersistValue = fromPersistValueEnum -- toPersistValue = toPersistValueEnum -- @ -toPersistValueEnum :: Enum a => a -> PersistValue +toPersistValueEnum :: (Enum a) => a -> PersistValue toPersistValueEnum = toPersistValue . fromEnum -- | Convenience function for getting a free 'PersistField' instance @@ -373,8 +571,87 @@ -- @ fromPersistValueEnum :: (Enum a, Bounded a) => PersistValue -> Either Text a fromPersistValueEnum v = fromPersistValue v >>= go - where go i = let res = toEnum i in - if i >= fromEnum (asTypeOf minBound res) && i <= fromEnum (asTypeOf maxBound res) - then Right res - else Left ("The number " `mappend` T.pack (show i) `mappend` " was out of the " - `mappend` "allowed bounds for an enum type") + where + go i = + let + res = toEnum i + in + if i >= fromEnum (asTypeOf minBound res) && i <= fromEnum (asTypeOf maxBound res) + then Right res + else + Left + ( "The number " + `mappend` T.pack (show i) + `mappend` " was out of the " + `mappend` "allowed bounds for an enum type" + ) + +-- | This type class is used with the @OverloadedLabels@ extension to +-- provide a more convenient means of using the 'EntityField' type. +-- 'EntityField' definitions are prefixed with the type name to avoid +-- ambiguity, but this ambiguity can result in verbose code. +-- +-- If you have a table @User@ with a @name Text@ field, then the +-- corresponding 'EntityField' is @UserName@. With this, we can write +-- @#name :: 'EntityField' User Text@. +-- +-- What's more fun is that the type is more general: it's actually +-- @ +-- #name +-- :: ('SymbolToField' "name" rec typ) +-- => EntityField rec typ +-- @ +-- +-- Which means it is *polymorphic* over the actual record. This allows you +-- to write code that can be generic over the tables, provided they have +-- the right fields. +-- +-- @since 2.11.0.0 +class SymbolToField (sym :: Symbol) rec typ | sym rec -> typ where + symbolToField :: EntityField rec typ + +-- | This instance delegates to 'SymbolToField' to provide +-- @OverloadedLabels@ support to the 'EntityField' type. +-- +-- @since 2.11.0.0 +instance (SymbolToField sym rec typ) => IsLabel sym (EntityField rec typ) where + fromLabel = symbolToField @sym + +-- | A type class which is used to witness that a type is safe to insert into +-- the database without providing a primary key. +-- +-- The @TemplateHaskell@ function 'mkPersist' will generate instances of this +-- class for any entity that it works on. If the entity has a default primary +-- key, then it provides a regular instance. If the entity has a @Primary@ +-- natural key, then this works fine. But if the entity has an @Id@ column with +-- no @default=@, then this does a 'TypeError' and forces the user to use +-- 'insertKey'. +-- +-- @since 2.14.0.0 +class SafeToInsert a + +type SafeToInsertErrorMessage a = + 'Text "The PersistEntity " + ':<>: ShowType a + ':<>: 'Text " does not have a default primary key." + ':$$: 'Text "This means that 'insert' will fail with a database error." + ':$$: 'Text "Please provide a default= clause inthe entity definition," + ':$$: 'Text "or use 'insertKey' instead to provide one." + +instance (TypeError (FunctionErrorMessage a b)) => SafeToInsert (a -> b) + +type FunctionErrorMessage a b = + 'Text + "Uh oh! It looks like you are trying to insert a function into the database." + ':$$: 'Text "Argument: " ':<>: 'ShowType a + ':$$: 'Text "Result: " ':<>: 'ShowType b + ':$$: 'Text "You probably need to add more arguments to an Entity construction." + +type EntityErrorMessage a = + 'Text "It looks like you're trying to `insert` an `Entity " + ':<>: 'ShowType a + ':<>: 'Text "` directly." + ':$$: 'Text "You want `insertKey` instead. As an example:" + ':$$: 'Text " insertKey (entityKey ent) (entityVal ent)" + +instance (TypeError (EntityErrorMessage a)) => SafeToInsert (Entity a) diff --git a/Database/Persist/Class/PersistField.hs b/Database/Persist/Class/PersistField.hs --- a/Database/Persist/Class/PersistField.hs +++ b/Database/Persist/Class/PersistField.hs @@ -1,48 +1,53 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module Database.Persist.Class.PersistField ( PersistField (..) - , SomePersistField (..) , getPersistMap + , OverflowNatural (..) ) where import Control.Arrow (second) import Control.Monad ((<=<)) -import Control.Applicative ((<|>)) import qualified Data.Aeson as A -import Data.ByteString.Char8 (ByteString, unpack, readInt) +import Data.ByteString.Char8 (ByteString, readInt, unpack) import qualified Data.ByteString.Lazy as L import Data.Fixed -import Data.Int (Int8, Int16, Int32, Int64) +import Data.Foldable (asum) +import Data.Int (Int16, Int32, Int64, Int8) import qualified Data.IntMap as IM +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as M -import Data.Monoid ((<>)) +import Data.Ratio (denominator, numerator) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Read (double) import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding.Error as TERR import qualified Data.Text.Lazy as TL +import Data.Text.Read (double) import qualified Data.Vector as V -import Data.Word (Word, Word8, Word16, Word32, Word64) +import Data.Word (Word, Word16, Word32, Word64, Word8) +import GHC.TypeLits import Numeric.Natural (Natural) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) import Database.Persist.Types.Base -import Data.Time (Day(..), TimeOfDay, UTCTime, - parseTimeM) -import Data.Time (defaultTimeLocale) +import Data.Time (Day (..), TimeOfDay, UTCTime, defaultTimeLocale, parseTimeM) #ifdef HIGH_PRECISION_DATE import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif - -- | This class teaches Persistent how to take a custom type and marshal it to and from a 'PersistValue', allowing it to be stored in a database. -- -- ==== __Examples__ @@ -109,7 +114,7 @@ fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String" - fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String. See the documentation of PersistDbSpecific for an example of using a custom database type with Persistent." + fromPersistValue (PersistLiteral_ _ _) = Left $ T.pack "Cannot convert PersistLiteral_ to String" fromPersistValue (PersistArray _) = Left $ T.pack "Cannot convert PersistArray to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif @@ -133,77 +138,90 @@ instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle - fromPersistValue x = Left $ fromPersistValueError "Int" "integer" x + fromPersistValue = fromPersistValueIntegral "Int" "integer" instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int8" "integer" x + fromPersistValue = fromPersistValueIntegral "Int8" "integer" instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int16" "integer" x + fromPersistValue = fromPersistValueIntegral "Int16" "integer" instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int32" "integer" x + fromPersistValue = fromPersistValueIntegral "Int32" "integer" instance PersistField Int64 where toPersistValue = PersistInt64 - fromPersistValue (PersistInt64 i) = Right i - fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle - fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle - Just (i,"") -> Right $ fromIntegral i - Just (i,extra) -> Left $ extraInputError "Int64" bs i extra - Nothing -> Left $ intParseError "Int64" bs - fromPersistValue x = Left $ fromPersistValueError "Int64" "integer" x + fromPersistValue = fromPersistValueIntegral "Int64" "integer" -extraInputError :: (Show result) - => Text -- ^ Haskell type - -> ByteString -- ^ Original bytestring - -> result -- ^ Integer result - -> ByteString -- ^ Extra bytestring - -> Text -- ^ Error message -extraInputError haskellType original result extra = T.concat - [ "Parsed " - , TE.decodeUtf8 original - , " into Haskell type `" - , haskellType - , "` with value" - , T.pack $ show result - , "but had extra input: " - , TE.decodeUtf8 extra - ] +fromPersistValueIntegral + :: (Integral a) => Text -> Text -> PersistValue -> Either Text a +fromPersistValueIntegral haskellType sqlType pv = case pv of + PersistInt64 i -> + Right (fromIntegral i) + PersistDouble i -> + Right $ truncate i -- oracle + PersistRational i -> + case denominator i of + 1 -> + Right $ fromIntegral $ numerator i + _denom -> + boom + PersistByteString bs -> + case readInt bs of -- oracle + Just (i, "") -> + Right $ fromIntegral i + Just (i, extra) -> + Left $ extraInputError haskellType bs i extra + Nothing -> + Left $ intParseError haskellType bs + _ -> + boom + where + boom = + Left $ fromPersistValueError haskellType sqlType pv -intParseError :: Text -- ^ Haskell type - -> ByteString -- ^ Original bytestring - -> Text -- ^ Error message -intParseError haskellType original = T.concat - [ "Failed to parse Haskell type `" - , haskellType - , " from " - , TE.decodeUtf8 original - ] +extraInputError + :: (Show result) + => Text + -- ^ Haskell type + -> ByteString + -- ^ Original bytestring + -> result + -- ^ Integer result + -> ByteString + -- ^ Extra bytestring + -> Text + -- ^ Error message +extraInputError haskellType original result extra = + T.concat + [ "Parsed " + , TE.decodeUtf8 original + , " into Haskell type `" + , haskellType + , "` with value" + , T.pack $ show result + , "but had extra input: " + , TE.decodeUtf8 extra + ] +intParseError + :: Text + -- ^ Haskell type + -> ByteString + -- ^ Original bytestring + -> Text + -- ^ Error message +intParseError haskellType original = + T.concat + [ "Failed to parse Haskell type `" + , haskellType + , " from " + , TE.decodeUtf8 original + ] + instance PersistField Data.Word.Word where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i @@ -240,8 +258,8 @@ toPersistValue = PersistRational . toRational fromPersistValue (PersistRational r) = Right $ fromRational r fromPersistValue (PersistText t) = case reads $ T.unpack t of -- NOTE: Sqlite can store rationals just as string - [(a, "")] -> Right a - _ -> Left $ "Can not read " <> t <> " as Fixed" + [(a, "")] -> Right a + _ -> Left $ "Can not read " <> t <> " as Fixed" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Fixed" "rational, string, double, or integer" x @@ -251,24 +269,48 @@ fromPersistValue (PersistRational r) = Right r fromPersistValue (PersistDouble d) = Right $ toRational d fromPersistValue (PersistText t) = case reads $ T.unpack t of -- NOTE: Sqlite can store rationals just as string - [(a, "")] -> Right $ toRational (a :: Pico) - _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" + [(a, "")] -> Right $ toRational (a :: Pico) + _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistByteString bs) = case double $ T.cons '0' $ TE.decodeUtf8With TERR.lenientDecode bs of - Right (ret,"") -> Right $ toRational ret - Right (a,b) -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show (a,b)) - Left xs -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show xs) - fromPersistValue x = Left $ fromPersistValueError "Rational" "rational, double, string, integer, or bytestring" x + Right (ret, "") -> Right $ toRational ret + Right (a, b) -> + Left $ + "Invalid bytestring[" + <> T.pack (show bs) + <> "]: expected a double but returned " + <> T.pack (show (a, b)) + Left xs -> + Left $ + "Invalid bytestring[" + <> T.pack (show bs) + <> "]: expected a double but returned " + <> T.pack (show xs) + fromPersistValue x = + Left $ + fromPersistValueError + "Rational" + "rational, double, string, integer, or bytestring" + x instance PersistField Bool where toPersistValue = PersistBool fromPersistValue (PersistBool b) = Right b fromPersistValue (PersistInt64 i) = Right $ i /= 0 fromPersistValue (PersistByteString i) = case readInt i of - Just (0,"") -> Right False - Just (1,"") -> Right True - xs -> Left $ T.pack $ "Failed to parse Haskell type `Bool` from PersistByteString. Original value:" ++ show i ++ ". Parsed by `readInt` as " ++ (show xs) ++ ". Expected '1'." - fromPersistValue x = Left $ fromPersistValueError "Bool" "boolean, integer, or bytestring of '1' or '0'" x + Just (0, "") -> Right False + Just (1, "") -> Right True + xs -> + Left $ + T.pack $ + "Failed to parse Haskell type `Bool` from PersistByteString. Original value:" + ++ show i + ++ ". Parsed by `readInt` as " + ++ (show xs) + ++ ". Expected '1'." + fromPersistValue x = + Left $ + fromPersistValueError "Bool" "boolean, integer, or bytestring of '1' or '0'" x instance PersistField Day where toPersistValue = PersistDay @@ -276,11 +318,11 @@ fromPersistValue (PersistInt64 i) = Right $ ModifiedJulianDay $ toInteger i fromPersistValue x@(PersistText t) = case reads $ T.unpack t of - (d, _):_ -> Right d + (d, _) : _ -> Right d _ -> Left $ fromPersistValueParseError "Day" x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of - (d, _):_ -> Right d + (d, _) : _ -> Right d _ -> Left $ fromPersistValueParseError "Day" x fromPersistValue x = Left $ fromPersistValueError "Day" "day, integer, string or bytestring" x @@ -289,59 +331,119 @@ fromPersistValue (PersistTimeOfDay d) = Right d fromPersistValue x@(PersistText t) = case reads $ T.unpack t of - (d, _):_ -> Right d + (d, _) : _ -> Right d _ -> Left $ fromPersistValueParseError "TimeOfDay" x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of - (d, _):_ -> Right d + (d, _) : _ -> Right d _ -> Left $ fromPersistValueParseError "TimeOfDay" x fromPersistValue x = Left $ fromPersistValueError "TimeOfDay" "time, string, or bytestring" x instance PersistField UTCTime where toPersistValue = PersistUTCTime - fromPersistValue (PersistUTCTime d) = Right d + fromPersistValue = utcTimeFromPersistValue + #ifdef HIGH_PRECISION_DATE - fromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i +utcTimeFromPersistValue :: PersistValue -> Either Text UTCTime +utcTimeFromPersistValue (PersistUTCTime d) = Right d +utcTimeFromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i +utcTimeFromPersistValue (PersistText t) = utcTimeFromPersistText t +utcTimeFromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ fromPersistValueParseError "UTCTime" x +utcTimeFromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x +#else +utcTimeFromPersistValue :: PersistValue -> Either Text UTCTime +utcTimeFromPersistValue (PersistUTCTime d) = Right d +utcTimeFromPersistValue (PersistText t) = utcTimeFromPersistText t +utcTimeFromPersistValue x@(PersistByteString s) = + case reads $ unpack s of + (d, _):_ -> Right d + _ -> Left $ fromPersistValueParseError "UTCTime" x +utcTimeFromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x #endif - fromPersistValue x@(PersistText t) = - case reads s of - (d, _):_ -> - Right d - _ -> - case parse8601 s <|> parsePretty s of + +utcTimeFromPersistText :: Text -> Either Text UTCTime +utcTimeFromPersistText t = + let + x = PersistText t + s = T.unpack t + in + case NonEmpty.nonEmpty (reads s) of + Nothing -> + case asum + [parse8601 s, parse8601NoTimezone s, parsePretty s, parsePrettyNoTimezone s] of Nothing -> Left $ fromPersistValueParseError "UTCTime" x Just x' -> Right x' - where - s = T.unpack t + Just matches -> + -- The 'Read UTCTime' instance in newer versions of 'time' is + -- more flexible when parsing UTCTime strings and will return + -- UTCTimes with different microsecond parsings. The last result + -- here contains the parsed UTCTime with as much microsecond + -- precision parsed as posssible. + Right $ fst $ NonEmpty.last matches + where + parse8601 = parseTime' "%FT%T%QZ" + parsePretty = parseTime' "%F %T%QZ" + -- Before 2.13.3.1 persistent-sqlite was missing the timezone "Z" for UTC, + -- which was only implicit, so these functions ensure backwards-compatibility. + parse8601NoTimezone = parseTime' "%FT%T%Q" + parsePrettyNoTimezone = parseTime' "%F %T%Q" + #if MIN_VERSION_time(1,5,0) - parse8601 = parseTimeM True defaultTimeLocale format8601 - parsePretty = parseTimeM True defaultTimeLocale formatPretty +parseTime' :: String -> String -> Maybe UTCTime +parseTime' = parseTimeM True defaultTimeLocale #else - parse8601 = parseTime defaultTimeLocale format8601 - parsePretty = parseTime defaultTimeLocale formatPretty +parseTime' :: String -> String -> Maybe UTCTime +parseTime' = parseTime defaultTimeLocale #endif - format8601 = "%FT%T%Q" - formatPretty = "%F %T%Q" - fromPersistValue x@(PersistByteString s) = - case reads $ unpack s of - (d, _):_ -> Right d - _ -> Left $ fromPersistValueParseError "UTCTime" x - fromPersistValue x = Left $ fromPersistValueError "UTCTime" "time, integer, string, or bytestring" x +-- | Prior to @persistent-2.11.0@, we provided an instance of +-- 'PersistField' for the 'Natural' type. This was in error, because +-- 'Natural' represents an infinite value, and databases don't have +-- reasonable types for this. +-- +-- The instance for 'Natural' used the 'Int64' underlying type, which will +-- cause underflow and overflow errors. This type has the exact same code +-- in the instances, and will work seamlessly. +-- +-- A more appropriate type for this is the 'Word' series of types from +-- "Data.Word". These have a bounded size, are guaranteed to be +-- non-negative, and are quite efficient for the database to store. +-- +-- @since 2.11.0 +newtype OverflowNatural = OverflowNatural {unOverflowNatural :: Natural} + deriving (Eq, Show, Ord, Num) -instance PersistField Natural where - toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral - fromPersistValue x = case (fromPersistValue x :: Either Text Int64) of - Left err -> Left $ T.replace "Int64" "Natural" err - Right int -> Right $ fromIntegral int -- TODO use bimap? +instance + ( TypeError + ( 'Text "The instance of PersistField for the Natural type was removed." + ':$$: 'Text "Please see the documentation for OverflowNatural if you want to " + ':$$: 'Text "continue using the old behavior or want to see documentation on " + ':$$: 'Text "why the instance was removed." + ':$$: 'Text "" + ':$$: 'Text "This error instance will be removed in a future release." + ) + ) + => PersistField Natural + where + toPersistValue = undefined + fromPersistValue = undefined -instance PersistField a => PersistField (Maybe a) where +instance PersistField OverflowNatural where + toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral . unOverflowNatural + fromPersistValue x = case (fromPersistValue x :: Either Text Int64) of + Left err -> Left $ T.replace "Int64" "OverflowNatural" err + Right int -> Right $ OverflowNatural $ fromIntegral int -- TODO use bimap? + +instance (PersistField a) => PersistField (Maybe a) where toPersistValue Nothing = PersistNull toPersistValue (Just a) = toPersistValue a fromPersistValue PersistNull = Right Nothing fromPersistValue x = Just <$> fromPersistValue x -instance {-# OVERLAPPABLE #-} PersistField a => PersistField [a] where +instance {-# OVERLAPPABLE #-} (PersistField a) => PersistField [a] where toPersistValue = PersistList . fmap toPersistValue fromPersistValue (PersistList l) = fromPersistList l fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) @@ -352,15 +454,18 @@ fromPersistValue (PersistNull) = Right [] fromPersistValue x = Left $ fromPersistValueError "List" "list, string, bytestring or null" x -instance PersistField a => PersistField (V.Vector a) where - toPersistValue = toPersistValue . V.toList - fromPersistValue = either (\e -> Left ("Failed to parse Haskell type `Vector`: " `T.append` e)) - (Right . V.fromList) . fromPersistValue +instance (PersistField a) => PersistField (V.Vector a) where + toPersistValue = toPersistValue . V.toList + fromPersistValue = + either + (\e -> Left ("Failed to parse Haskell type `Vector`: " `T.append` e)) + (Right . V.fromList) + . fromPersistValue instance (Ord a, PersistField a) => PersistField (S.Set a) where toPersistValue = PersistList . fmap toPersistValue . S.toList fromPersistValue (PersistList list) = - S.fromList <$> fromPersistList list + S.fromList <$> fromPersistList list fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) fromPersistValue (PersistByteString bs) | Just values <- A.decode' (L.fromChunks [bs]) = @@ -368,19 +473,20 @@ fromPersistValue PersistNull = Right S.empty fromPersistValue x = Left $ fromPersistValueError "Set" "list, string, bytestring or null" x -instance (PersistField a, PersistField b) => PersistField (a,b) where - toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y] +instance (PersistField a, PersistField b) => PersistField (a, b) where + toPersistValue (x, y) = PersistList [toPersistValue x, toPersistValue y] fromPersistValue v = case fromPersistValue v of - Right [x,y] -> (,) <$> fromPersistValue x <*> fromPersistValue y - Left e -> Left e - _ -> Left $ T.pack $ "Expected 2 item PersistList, received: " ++ show v + Right [x, y] -> (,) <$> fromPersistValue x <*> fromPersistValue y + Left e -> Left e + _ -> + Left $ T.pack $ "Expected 2 item PersistList, received: " ++ show v -instance PersistField v => PersistField (IM.IntMap v) where +instance (PersistField v) => PersistField (IM.IntMap v) where toPersistValue = toPersistValue . IM.toList fromPersistValue = fmap IM.fromList . fromPersistValue -instance PersistField v => PersistField (M.Map T.Text v) where +instance (PersistField v) => PersistField (M.Map T.Text v) where toPersistValue = PersistMap . fmap (second toPersistValue) . M.toList fromPersistValue = fromPersistMap <=< getPersistMap @@ -388,73 +494,94 @@ toPersistValue = id fromPersistValue = Right -fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a] +fromPersistList :: (PersistField a) => [PersistValue] -> Either T.Text [a] fromPersistList = mapM fromPersistValue -fromPersistMap :: PersistField v - => [(T.Text, PersistValue)] - -> Either T.Text (M.Map T.Text v) -fromPersistMap = foldShortLeft fromPersistValue [] where +fromPersistMap + :: (PersistField v) + => [(T.Text, PersistValue)] + -> Either T.Text (M.Map T.Text v) +fromPersistMap = foldShortLeft fromPersistValue [] + where -- a fold that short-circuits on Left. foldShortLeft f = go where go acc [] = Right $ M.fromList acc - go acc ((k, v):kvs) = - case f v of - Left e -> Left e - Right v' -> go ((k,v'):acc) kvs + go acc ((k, v) : kvs) = + case f v of + Left e -> Left e + Right v' -> go ((k, v') : acc) kvs -- | FIXME Add documentation to that. getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)] getPersistMap (PersistMap kvs) = Right kvs -getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t) +getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t) getPersistMap (PersistByteString bs) | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs getPersistMap PersistNull = Right [] -getPersistMap x = Left $ fromPersistValueError "[(Text, PersistValue)]" "map, string, bytestring or null" x - -data SomePersistField = forall a. PersistField a => SomePersistField a -instance PersistField SomePersistField where - toPersistValue (SomePersistField a) = toPersistValue a - fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either Text Text) +getPersistMap x = + Left $ + fromPersistValueError + "[(Text, PersistValue)]" + "map, string, bytestring or null" + x instance PersistField Checkmark where - toPersistValue Active = PersistBool True + toPersistValue Active = PersistBool True toPersistValue Inactive = PersistNull - fromPersistValue PersistNull = Right Inactive - fromPersistValue (PersistBool True) = Right Active - fromPersistValue (PersistInt64 1) = Right Active + fromPersistValue PersistNull = Right Inactive + fromPersistValue (PersistBool True) = Right Active + fromPersistValue (PersistInt64 1) = Right Active fromPersistValue (PersistByteString i) = case readInt i of - Just (0,"") -> Left "Failed to parse Haskell type `Checkmark`: found `0`, expected `1` or NULL" - Just (1,"") -> Right Active - xs -> Left $ T.pack $ "Failed to parse Haskell type `Checkmark` from PersistByteString. Original value:" ++ show i ++ ". Parsed by `readInt` as " ++ (show xs) ++ ". Expected '1'." + Just (0, "") -> + Left "Failed to parse Haskell type `Checkmark`: found `0`, expected `1` or NULL" + Just (1, "") -> Right Active + xs -> + Left $ + T.pack $ + "Failed to parse Haskell type `Checkmark` from PersistByteString. Original value:" + ++ show i + ++ ". Parsed by `readInt` as " + ++ (show xs) + ++ ". Expected '1'." fromPersistValue (PersistBool False) = - Left $ T.pack "PersistField Checkmark: found unexpected FALSE value" + Left $ T.pack "PersistField Checkmark: found unexpected FALSE value" fromPersistValue other = - Left $ fromPersistValueError "Checkmark" "boolean, integer, bytestring or null" other - + Left $ + fromPersistValueError "Checkmark" "boolean, integer, bytestring or null" other -fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" - -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". - -> PersistValue -- ^ Incorrect value - -> Text -- ^ Error message -fromPersistValueError haskellType databaseType received = T.concat - [ "Failed to parse Haskell type `" - , haskellType - , "`; expected " - , databaseType - , " from database, but received: " - , T.pack (show received) - , ". Potential solution: Check that your database schema matches your Persistent model definitions." - ] +fromPersistValueError + :: Text + -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" + -> Text + -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". + -> PersistValue + -- ^ Incorrect value + -> Text + -- ^ Error message +fromPersistValueError haskellType databaseType received = + T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`; expected " + , databaseType + , " from database, but received: " + , T.pack (show received) + , ". Potential solution: Check that your database schema matches your Persistent model definitions." + ] -fromPersistValueParseError :: (Show a) - => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" - -> a -- ^ Received value - -> Text -- ^ Error message -fromPersistValueParseError haskellType received = T.concat - [ "Failed to parse Haskell type `" - , haskellType - , "`, but received " - , T.pack (show received) - ] +fromPersistValueParseError + :: (Show a) + => Text + -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" + -> a + -- ^ Received value + -> Text + -- ^ Error message +fromPersistValueParseError haskellType received = + T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`, but received " + , T.pack (show received) + ] diff --git a/Database/Persist/Class/PersistQuery.hs b/Database/Persist/Class/PersistQuery.hs --- a/Database/Persist/Class/PersistQuery.hs +++ b/Database/Persist/Class/PersistQuery.hs @@ -1,37 +1,46 @@ +{-# LANGUAGE ExplicitForAll #-} + module Database.Persist.Class.PersistQuery - ( PersistQueryRead (..) + ( selectList + , PersistQueryRead (..) , PersistQueryWrite (..) , selectSource , selectKeys - , selectList , selectKeysList ) where import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (ReaderT, MonadReader) +import Control.Monad.Reader (MonadReader, ReaderT) import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, with) -import Data.Conduit (ConduitM, (.|), await, runConduit) +import Data.Conduit (ConduitM, await, runConduit, (.|)) import qualified Data.Conduit.List as CL -import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity +import Database.Persist.Class.PersistStore -- | Backends supporting conditional read operations. class (PersistCore backend, PersistStoreRead backend) => PersistQueryRead backend where -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. + -- + -- NOTE: This function returns an 'Acquire' and a 'ConduitM', which implies + -- that it streams from the database. It does not. Please use 'selectList' + -- to simplify the code. If you want streaming behavior, consider + -- @persistent-pagination@ which efficiently chunks a query into ranges, or + -- investigate a backend-specific streaming solution. selectSourceRes - :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2) - => [Filter record] - -> [SelectOpt record] - -> ReaderT backend m1 (Acquire (ConduitM () (Entity record) m2 ())) + :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m1 (Acquire (ConduitM () (Entity record) m2 ())) -- | Get just the first record for the criterion. - selectFirst :: (MonadIO m, PersistRecordBackend record backend) - => [Filter record] - -> [SelectOpt record] - -> ReaderT backend m (Maybe (Entity record)) + selectFirst + :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m (Maybe (Entity record)) selectFirst filts opts = do srcRes <- selectSourceRes filts (LimitTo 1 : opts) liftIO $ with srcRes (\src -> runConduit $ src .| await) @@ -44,26 +53,49 @@ -> ReaderT backend m1 (Acquire (ConduitM () (Key record) m2 ())) -- | The total number of records fulfilling the given criterion. - count :: (MonadIO m, PersistRecordBackend record backend) - => [Filter record] -> ReaderT backend m Int + count + :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> ReaderT backend m Int + -- | Check if there is at least one record fulfilling the given criterion. + -- + -- @since 2.11 + exists + :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> ReaderT backend m Bool + -- | Backends supporting conditional write operations -class (PersistQueryRead backend, PersistStoreWrite backend) => PersistQueryWrite backend where +class + (PersistQueryRead backend, PersistStoreWrite backend) => + PersistQueryWrite backend + where -- | Update individual fields on any record matching the given criterion. - updateWhere :: (MonadIO m, PersistRecordBackend record backend) - => [Filter record] -> [Update record] -> ReaderT backend m () + updateWhere + :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> [Update record] -> ReaderT backend m () -- | Delete all records matching the given criterion. - deleteWhere :: (MonadIO m, PersistRecordBackend record backend) - => [Filter record] -> ReaderT backend m () + deleteWhere + :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> ReaderT backend m () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. +-- +-- WARNING: This function returns a 'ConduitM', which suggests that it streams +-- the results. It does not stream results on most backends. If you need +-- streaming, see @persistent-pagination@ for a means of chunking results based +-- on indexed ranges. selectSource - :: (PersistQueryRead backend, MonadResource m, PersistRecordBackend record backend, MonadReader backend m) - => [Filter record] - -> [SelectOpt record] - -> ConduitM () (Entity record) m () + :: forall record backend m + . ( PersistQueryRead backend + , MonadResource m + , PersistRecordBackend record backend + , MonadReader backend m + ) + => [Filter record] + -> [SelectOpt record] + -> ConduitM () (Entity record) m () selectSource filts opts = do srcRes <- liftPersist $ selectSourceRes filts opts (releaseKey, src) <- allocateAcquire srcRes @@ -71,30 +103,111 @@ release releaseKey -- | Get the 'Key's of all records matching the given criterion. -selectKeys :: (PersistQueryRead backend, MonadResource m, PersistRecordBackend record backend, MonadReader backend m) - => [Filter record] - -> [SelectOpt record] - -> ConduitM () (Key record) m () +-- +-- For an example, see 'selectList'. +selectKeys + :: forall record backend m + . ( PersistQueryRead backend + , MonadResource m + , PersistRecordBackend record backend + , MonadReader backend m + ) + => [Filter record] + -> [SelectOpt record] + -> ConduitM () (Key record) m () selectKeys filts opts = do srcRes <- liftPersist $ selectKeysRes filts opts (releaseKey, src) <- allocateAcquire srcRes src release releaseKey --- | Call 'selectSource' but return the result as a list. -selectList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) - => [Filter record] - -> [SelectOpt record] - -> ReaderT backend m [Entity record] +-- | Returns a @['Entity' record]@ corresponding to the filters and options +-- provided. +-- +-- Filters are constructed using the operators defined in "Database.Persist" +-- (and re-exported from "Database.Persist.Sql"). Let's look at some examples: +-- +-- @ +-- usersWithAgeOver40 :: 'SqlPersistT' 'IO' ['Entity' User] +-- usersWithAgeOver40 = +-- 'selectList' [UserAge 'Database.Persist.>=.' 40] [] +-- @ +-- +-- If you provide multiple values in the list, the conditions are @AND@ed +-- together. +-- +-- @ +-- usersWithAgeBetween30And50 :: 'SqlPersistT' 'IO' ['Entity' User] +-- usersWithAgeBetween30And50 = +-- 'selectList' +-- [ UserAge 'Database.Persist.>=.' 30 +-- , UserAge 'Database.Persist.<=.' 50 +-- ] +-- [] +-- @ +-- +-- The second list contains the 'SelectOpt' for a record. We can select the +-- first ten records with 'LimitTo' +-- +-- @ +-- firstTenUsers = +-- 'selectList' [] ['LimitTo' 10] +-- @ +-- +-- And we can select the second ten users with 'OffsetBy'. +-- +-- @ +-- secondTenUsers = +-- 'selectList' [] ['LimitTo' 10, 'OffsetBy' 10] +-- @ +-- +-- +-- +-- The type of record can usually be infered from the types of the provided filters +-- and select options. In the previous two examples, though, you'll notice that the +-- select options are polymorphic, applying to any record type. In order to help +-- type inference in such situations, or simply as an enhancement to readability, +-- you might find type application useful, illustrated below. +-- +-- @ +-- {-# LANGUAGE TypeApplications #-} +-- ... +-- +-- firstTenUsers = +-- 'selectList' @User [] ['LimitTo' 10] +-- +-- secondTenUsers = +-- 'selectList' @User [] ['LimitTo' 10, 'OffsetBy' 10] +-- @ +-- +-- With 'Asc' and 'Desc', we can provide the field we want to sort on. We can +-- provide multiple sort orders - later ones are used to sort records that are +-- equal on the first field. +-- +-- @ +-- newestUsers = +-- selectList [] ['Desc' UserCreatedAt, 'LimitTo' 10] +-- +-- oldestUsers = +-- selectList [] ['Asc' UserCreatedAt, 'LimitTo' 10] +-- @ +selectList + :: forall record backend m + . (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m [Entity record] selectList filts opts = do srcRes <- selectSourceRes filts opts liftIO $ with srcRes (\src -> runConduit $ src .| CL.consume) -- | Call 'selectKeys' but return the result as a list. -selectKeysList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) - => [Filter record] - -> [SelectOpt record] - -> ReaderT backend m [Key record] +selectKeysList + :: forall record backend m + . (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m [Key record] selectKeysList filts opts = do srcRes <- selectKeysRes filts opts liftIO $ with srcRes (\src -> runConduit $ src .| CL.consume) diff --git a/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -1,6 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TypeOperators #-} + module Database.Persist.Class.PersistStore ( HasPersistBackend (..) + , withBaseBackend , IsPersistBackend (..) , PersistRecordBackend , liftPersist @@ -14,19 +18,21 @@ , belongsToJust , insertEntity , insertRecord - , ToBackendKey(..) - , BackendCompatible(..) + , ToBackendKey (..) + , BackendCompatible (..) + , withCompatibleBackend ) where import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader (ask), runReaderT) -import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Reader (ReaderT, withReaderT) import qualified Data.Aeson as A import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Text as T +import GHC.Stack import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField @@ -42,6 +48,17 @@ class HasPersistBackend backend where type BaseBackend backend persistBackend :: backend -> BaseBackend backend + +-- | Run a query against a larger backend by plucking out @BaseBackend backend@ +-- +-- This is a helper for reusing existing queries when expanding the backend type. +-- +-- @since 2.12.0 +withBaseBackend + :: (HasPersistBackend backend) + => ReaderT (BaseBackend backend) m a -> ReaderT backend m a +withBaseBackend = withReaderT persistBackend + -- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@. -- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@. class (HasPersistBackend backend) => IsPersistBackend backend where @@ -50,6 +67,10 @@ -- to accidentally run a write query against a read-only database. mkPersistBackend :: BaseBackend backend -> backend +-- NB: there is a deliberate *lack* of an equivalent to 'withBaseBackend' for +-- 'IsPersistentBackend'. We don't want it to be easy for the user to construct +-- a backend when they're not meant to. + -- | This class witnesses that two backend are compatible, and that you can -- convert from the @sub@ backend into the @sup@ backend. This is similar -- to the 'HasPersistBackend' and 'IsPersistBackend' classes, but where you @@ -61,7 +82,7 @@ -- @ -- foo :: -- ( 'PersistEntity' record --- , 'PeristEntityBackend' record ~ 'BaseBackend' backend +-- , 'PersistEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @ @@ -87,15 +108,27 @@ -- -- -- after: -- asdf' :: 'BackendCompatible' SqlBackend backend => ReaderT backend m () --- asdf' = withReaderT 'projectBackend' asdf +-- asdf' = 'withCompatibleBackend' asdf -- @ -- -- @since 2.7.1 class BackendCompatible sup sub where projectBackend :: sub -> sup +-- | Run a query against a compatible backend, by projecting the backend +-- +-- This is a helper for using queries which run against a specific backend type +-- that your backend is compatible with. +-- +-- @since 2.12.0 +withCompatibleBackend + :: (BackendCompatible sup sub) + => ReaderT sup m a -> ReaderT sub m a +withCompatibleBackend = withReaderT projectBackend + -- | A convenient alias for common type signatures -type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) +type PersistRecordBackend record backend = + (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) liftPersist :: (MonadIO m, MonadReader backend m) @@ -113,22 +146,31 @@ -- -- A 'Key' that instead uses a custom type will not be an instance of -- 'ToBackendKey'. -class ( PersistEntity record - , PersistEntityBackend record ~ backend - , PersistCore backend - ) => ToBackendKey backend record where - toBackendKey :: Key record -> BackendKey backend +class + ( PersistEntity record + , PersistEntityBackend record ~ backend + , PersistCore backend + ) => + ToBackendKey backend record + where + toBackendKey :: Key record -> BackendKey backend fromBackendKey :: BackendKey backend -> Key record class PersistCore backend where data BackendKey backend class - ( Show (BackendKey backend), Read (BackendKey backend) - , Eq (BackendKey backend), Ord (BackendKey backend) - , PersistCore backend - , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend) - ) => PersistStoreRead backend where + ( Show (BackendKey backend) + , Read (BackendKey backend) + , Eq (BackendKey backend) + , Ord (BackendKey backend) + , PersistCore backend + , PersistField (BackendKey backend) + , A.ToJSON (BackendKey backend) + , A.FromJSON (BackendKey backend) + ) => + PersistStoreRead backend + where -- | Get a record by identifier, if available. -- -- === __Example usage__ @@ -147,7 +189,9 @@ -- > +------+-----+ -- > | SPJ | 40 | -- > +------+-----+ - get :: (MonadIO m, PersistRecordBackend record backend) + get + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) => Key record -> ReaderT backend m (Maybe record) -- | Get many records by their respective identifiers, if available. @@ -173,22 +217,30 @@ -- > | 2 | Simon | 41 | -- > +----+-------+-----+ getMany - :: (MonadIO m, PersistRecordBackend record backend) + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) => [Key record] -> ReaderT backend m (Map (Key record) record) getMany [] = return Map.empty getMany ks = do vs <- mapM get ks - let kvs = zip ks vs - let kvs' = (fmap Maybe.fromJust) `fmap` filter (\(_,v) -> Maybe.isJust v) kvs + let + kvs = zip ks vs + let + kvs' = (fmap Maybe.fromJust) `fmap` filter (\(_, v) -> Maybe.isJust v) kvs return $ Map.fromList kvs' class - ( Show (BackendKey backend), Read (BackendKey backend) - , Eq (BackendKey backend), Ord (BackendKey backend) - , PersistStoreRead backend - , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend) - ) => PersistStoreWrite backend where - + ( Show (BackendKey backend) + , Read (BackendKey backend) + , Eq (BackendKey backend) + , Ord (BackendKey backend) + , PersistStoreRead backend + , PersistField (BackendKey backend) + , A.ToJSON (BackendKey backend) + , A.FromJSON (BackendKey backend) + ) => + PersistStoreWrite backend + where -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id). -- @@ -212,8 +264,10 @@ -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+ - insert :: (MonadIO m, PersistRecordBackend record backend) - => record -> ReaderT backend m (Key record) + insert + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) + => record -> ReaderT backend m (Key record) -- | Same as 'insert', but doesn't return a @Key@. -- @@ -235,8 +289,10 @@ -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+ - insert_ :: (MonadIO m, PersistRecordBackend record backend) - => record -> ReaderT backend m () + insert_ + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) + => record -> ReaderT backend m () insert_ record = insert record >> return () -- | Create multiple records in the database and return their 'Key's. @@ -273,8 +329,10 @@ -- > +-----+------+-----+ -- > |5 |Jane |20 | -- > +-----+------+-----+ - insertMany :: (MonadIO m, PersistRecordBackend record backend) - => [record] -> ReaderT backend m [Key record] + insertMany + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) + => [record] -> ReaderT backend m [Key record] insertMany = mapM insert -- | Same as 'insertMany', but doesn't return any 'Key's. @@ -304,8 +362,10 @@ -- > +-----+------+-----+ -- > |5 |Jane |20 | -- > +-----+------+-----+ - insertMany_ :: (MonadIO m, PersistRecordBackend record backend) - => [record] -> ReaderT backend m () + insertMany_ + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) + => [record] -> ReaderT backend m () insertMany_ x = insertMany x >> return () -- | Same as 'insertMany_', but takes an 'Entity' instead of just a record. @@ -336,8 +396,10 @@ -- > +-----+------+-----+ -- > |4 |Eva |38 | -- > +-----+------+-----+ - insertEntityMany :: (MonadIO m, PersistRecordBackend record backend) - => [Entity record] -> ReaderT backend m () + insertEntityMany + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => [Entity record] -> ReaderT backend m () insertEntityMany = mapM_ (\(Entity k record) -> insertKey k record) -- | Create a new record in the database using the given key. @@ -361,8 +423,10 @@ -- > +-----+------+-----+ -- > |3 |Alice |20 | -- > +-----+------+-----+ - insertKey :: (MonadIO m, PersistRecordBackend record backend) - => Key record -> record -> ReaderT backend m () + insertKey + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Key record -> record -> ReaderT backend m () -- | Put the record in the database with the given key. -- Unlike 'replace', if a record with the given key does not @@ -424,8 +488,10 @@ -- > +-----+------+-----+ -- > |3 |X |999 | -- > +-----+------+-----+ - repsert :: (MonadIO m, PersistRecordBackend record backend) - => Key record -> record -> ReaderT backend m () + repsert + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Key record -> record -> ReaderT backend m () -- | Put many entities into the database. -- @@ -455,7 +521,8 @@ -- > |999 |Mr. X |999 | -- > +-----+----------------+---------+ repsertMany - :: (MonadIO m, PersistRecordBackend record backend) + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) => [(Key record, record)] -> ReaderT backend m () repsertMany = mapM_ (uncurry repsert) @@ -480,8 +547,10 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ - replace :: (MonadIO m, PersistRecordBackend record backend) - => Key record -> record -> ReaderT backend m () + replace + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Key record -> record -> ReaderT backend m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist. @@ -500,8 +569,10 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ - delete :: (MonadIO m, PersistRecordBackend record backend) - => Key record -> ReaderT backend m () + delete + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Key record -> ReaderT backend m () -- | Update individual fields on a specific record. -- @@ -523,8 +594,10 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ - update :: (MonadIO m, PersistRecordBackend record backend) - => Key record -> [Update record] -> ReaderT backend m () + update + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Key record -> [Update record] -> ReaderT backend m () -- | Update individual fields on a specific record, and retrieve the -- updated value from the database. @@ -550,13 +623,14 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ - updateGet :: (MonadIO m, PersistRecordBackend record backend) - => Key record -> [Update record] -> ReaderT backend m record + updateGet + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Key record -> [Update record] -> ReaderT backend m record updateGet key ups = do update key ups get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return - -- | Same as 'get', but for a non-null (not Maybe) foreign key. -- Unsafe unless your database is enforcing that the foreign key is valid. -- @@ -583,13 +657,18 @@ -- mrx <- getJustUnknown -- -- This just throws an error. -getJust :: ( PersistStoreRead backend - , PersistRecordBackend record backend - , MonadIO m - ) => Key record -> ReaderT backend m record -getJust key = get key >>= maybe - (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) - return +getJust + :: forall record backend m + . ( PersistStoreRead backend + , PersistRecordBackend record backend + , MonadIO m + ) + => Key record -> ReaderT backend m record +getJust key = + get key + >>= maybe + (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) + return -- | Same as 'getJust', but returns an 'Entity' instead of just the record. -- @@ -612,40 +691,45 @@ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getJustEntity - :: (PersistEntityBackend record ~ BaseBackend backend - ,MonadIO m - ,PersistEntity record - ,PersistStoreRead backend) - => Key record -> ReaderT backend m (Entity record) + :: forall record backend m + . ( PersistEntityBackend record ~ BaseBackend backend + , MonadIO m + , PersistEntity record + , PersistStoreRead backend + ) + => Key record -> ReaderT backend m (Entity record) getJustEntity key = do - record <- getJust key - return $ - Entity - { entityKey = key - , entityVal = record - } + record <- getJust key + return $ + Entity + { entityKey = key + , entityVal = record + } -- | Curry this to make a convenience function that loads an associated model. -- -- > foreign = belongsTo foreignId -belongsTo :: - ( PersistStoreRead backend - , PersistEntity ent1 - , PersistRecordBackend ent2 backend - , MonadIO m - ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2) +belongsTo + :: forall ent1 ent2 backend m + . ( PersistStoreRead backend + , PersistEntity ent1 + , PersistRecordBackend ent2 backend + , MonadIO m + ) + => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of Nothing -> return Nothing Just f -> get f -- | Same as 'belongsTo', but uses @getJust@ and therefore is similarly unsafe. -belongsToJust :: - ( PersistStoreRead backend - , PersistEntity ent1 - , PersistRecordBackend ent2 backend - , MonadIO m - ) - => (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2 +belongsToJust + :: forall ent1 ent2 backend m + . ( PersistStoreRead backend + , PersistEntity ent1 + , PersistRecordBackend ent2 backend + , MonadIO m + ) + => (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2 belongsToJust getForeignKey model = getJust $ getForeignKey model -- | Like @insert@, but returns the complete @Entity@. @@ -670,14 +754,21 @@ -- > +----+---------+-----+ -- > | 3 | Haskell | 81 | -- > +----+---------+-----+ -insertEntity :: - ( PersistStoreWrite backend - , PersistRecordBackend e backend - , MonadIO m - ) => e -> ReaderT backend m (Entity e) +insertEntity + :: forall e backend m + . ( PersistStoreWrite backend + , PersistRecordBackend e backend + , SafeToInsert e + , MonadIO m + , HasCallStack + ) + => e -> ReaderT backend m (Entity e) insertEntity e = do eid <- insert e - return $ Entity eid e + Maybe.fromMaybe (error errorMessage) <$> getEntity eid + where + errorMessage = + "persistent: failed to get record from database despite receiving key from the database" -- | Like @get@, but returns the complete @Entity@. -- @@ -697,11 +788,13 @@ -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ -getEntity :: - ( PersistStoreRead backend - , PersistRecordBackend e backend - , MonadIO m - ) => Key e -> ReaderT backend m (Maybe (Entity e)) +getEntity + :: forall e backend m + . ( PersistStoreRead backend + , PersistRecordBackend e backend + , MonadIO m + ) + => Key e -> ReaderT backend m (Maybe (Entity e)) getEntity key = do maybeModel <- get key return $ fmap (key `Entity`) maybeModel @@ -731,11 +824,19 @@ -- > |3 |Dave |50 | -- > +-----+------+-----+ insertRecord - :: (PersistEntityBackend record ~ BaseBackend backend - ,PersistEntity record - ,MonadIO m - ,PersistStoreWrite backend) - => record -> ReaderT backend m record + :: forall record backend m + . ( PersistEntityBackend record ~ BaseBackend backend + , PersistEntity record + , MonadIO m + , PersistStoreWrite backend + , SafeToInsert record + , HasCallStack + ) + => record -> ReaderT backend m record insertRecord record = do - insert_ record - return $ record + k <- insert record + let + errorMessage = + "persistent: failed to retrieve a record despite receiving a key from the database" + mentity <- get k + return $ Maybe.fromMaybe (error errorMessage) mentity diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -3,41 +3,42 @@ {-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique - ( PersistUniqueRead(..) - , PersistUniqueWrite(..) - , OnlyOneUniqueKey(..) - , onlyOneUniqueDef - , AtLeastOneUniqueKey(..) - , atLeastOneUniqueDef - , NoUniqueKeysError - , MultipleUniqueKeysError - , getByValue - , getByValueUniques - , insertBy - , insertUniqueEntity - , replaceUnique - , checkUnique - , onlyUnique - , defaultPutMany - , persistUniqueKeyValues - ) - where + ( PersistUniqueRead (..) + , PersistUniqueWrite (..) + , OnlyOneUniqueKey (..) + , onlyOneUniqueDef + , AtLeastOneUniqueKey (..) + , atLeastOneUniqueDef + , NoUniqueKeysError + , MultipleUniqueKeysError + , getByValue + , getByValueUniques + , insertBy + , insertUniqueEntity + , replaceUnique + , checkUnique + , checkUniqueUpdateable + , onlyUnique + , defaultUpsertBy + , defaultPutMany + , persistUniqueKeyValues + ) +where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Function (on) -import Data.List ((\\), deleteFirstsBy) -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List (deleteFirstsBy, (\\)) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map -import Data.Maybe (catMaybes) -import Data.Text (Text) -import GHC.TypeLits (ErrorMessage(..)) +import Data.Maybe (catMaybes, isJust) +import GHC.TypeLits (ErrorMessage (..)) -import Database.Persist.Types -import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity +import Database.Persist.Class.PersistStore +import Database.Persist.Types -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -53,11 +54,11 @@ -- SQL backends automatically create uniqueness constraints, but for MongoDB -- you must manually place a unique index on a field to have a uniqueness -- constraint. --- -class (PersistCore backend, PersistStoreRead backend) => - PersistUniqueRead backend where +class (PersistStoreRead backend) => PersistUniqueRead backend where -- | Get a record by unique key, if available. Returns also the identifier. -- + -- If your unique key contains a nullable field, then, by default, getBy will not match if any of the fields are NULL. + -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>: @@ -75,9 +76,31 @@ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getBy - :: (MonadIO m, PersistRecordBackend record backend) + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) + -- | Returns True if a record with this unique key exists, otherwise False. + -- + -- === __Example usage__ + -- + -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>: + -- + -- > existsBySpjName :: MonadIO m => ReaderT SqlBackend m Bool + -- > existsBySpjName = existsBy $ UniqueUserName "SPJ" + -- + -- > spjEntExists <- existsBySpjName + -- + -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will return + -- the value True. + -- + -- @since 2.14.5 + existsBy + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) + => Unique record -> ReaderT backend m Bool + existsBy uniq = isJust <$> getBy uniq + -- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for -- conflicts. You could instead optimistically attempt to perform the @@ -87,8 +110,10 @@ -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction. -class (PersistUniqueRead backend, PersistStoreWrite backend) => - PersistUniqueWrite backend where +class + (PersistUniqueRead backend, PersistStoreWrite backend) => + PersistUniqueWrite backend + where -- | Delete a specific record by unique key. Does nothing if no record -- matches. -- @@ -97,7 +122,7 @@ -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, -- -- > deleteBySpjName :: MonadIO m => ReaderT SqlBackend m () - -- > deleteBySpjName = deleteBy UniqueUserName "SPJ" + -- > deleteBySpjName = deleteBy (UniqueUserName "SPJ") -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will produce this: -- @@ -107,7 +132,8 @@ -- > |2 |Simon |41 | -- > +-----+------+-----+ deleteBy - :: (MonadIO m, PersistRecordBackend record backend) + :: forall record m + . (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () -- | Like 'insert', but returns 'Nothing' when the record @@ -132,7 +158,8 @@ -- -- Linus's record was inserted to <#dataset-persist-unique-1 dataset-1>, while SPJ wasn't because SPJ already exists in <#dataset-persist-unique-1 dataset-1>. insertUnique - :: (MonadIO m, PersistRecordBackend record backend) + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum @@ -140,6 +167,38 @@ Nothing -> Just `liftM` insert datum Just _ -> return Nothing + -- | Same as 'insertUnique' but doesn't return a @Key@. + -- + -- === __Example usage__ + -- + -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, we try to insert the following two records: + -- + -- > linusId <- insertUnique_ $ User "Linus" 48 + -- > spjId <- insertUnique_ $ User "SPJ" 90 + -- + -- > +-----+------+-----+ + -- > |id |name |age | + -- > +-----+------+-----+ + -- > |1 |SPJ |40 | + -- > +-----+------+-----+ + -- > |2 |Simon |41 | + -- > +-----+------+-----+ + -- > |3 |Linus |48 | + -- > +-----+------+-----+ + -- + -- Linus's record was inserted to <#dataset-persist-unique-1 dataset-1>, while SPJ wasn't because SPJ already exists in <#dataset-persist-unique-1 dataset-1>. + -- + -- @since 2.14.5.0 + insertUnique_ + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) + => record -> ReaderT backend m (Maybe ()) + insertUnique_ datum = do + conflict <- checkUnique datum + case conflict of + Nothing -> Just `liftM` insert_ datum + Just _ -> return Nothing + -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; @@ -150,7 +209,7 @@ -- First, we try to explain 'upsert' using <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>. -- -- > upsertSpj :: MonadIO m => [Update User] -> ReaderT SqlBackend m (Maybe (Entity User)) - -- > upsertSpj updates = upsert (User "SPJ" 999) upadtes + -- > upsertSpj updates = upsert (User "SPJ" 999) updates -- -- > mSpjEnt <- upsertSpj [UserAge +=. 15] -- @@ -190,7 +249,12 @@ -- that this record has multiple unique keys, and suggests that we look for -- 'upsertBy' to select the unique key we want. upsert - :: (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record) + :: forall record m + . ( MonadIO m + , PersistRecordBackend record backend + , OnlyOneUniqueKey record + , SafeToInsert record + ) => record -- ^ new record to insert -> [Update record] @@ -257,7 +321,8 @@ -- > |3 |X |999 | -- > +-----+-----+-----+ upsertBy - :: (MonadIO m, PersistRecordBackend record backend) + :: forall record m + . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => Unique record -- ^ uniqueness constraint to find by -> record @@ -266,12 +331,7 @@ -- ^ updates to perform if the record already exists -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation - upsertBy uniqueKey record updates = do - mrecord <- getBy uniqueKey - maybe (insertEntity record) (`updateGetEntity` updates) mrecord - where - updateGetEntity (Entity k _) upds = - (Entity k) `liftM` (updateGet k upds) + upsertBy = defaultUpsertBy -- | Put many records into db -- @@ -280,10 +340,11 @@ -- -- @since 2.8.1 putMany - :: - ( MonadIO m - , PersistRecordBackend record backend - ) + :: forall record m + . ( MonadIO m + , PersistRecordBackend record backend + , SafeToInsert record + ) => [record] -- ^ A list of the records you want to insert or replace. -> ReaderT backend m () @@ -295,19 +356,19 @@ -- instances for records that have 0 or multiple unique keys. -- -- @since 2.10.0 -class PersistEntity record => OnlyOneUniqueKey record where +class (PersistEntity record) => OnlyOneUniqueKey record where onlyUniqueP :: record -> Unique record -- | Given a proxy for a 'PersistEntity' record, this returns the sole -- 'UniqueDef' for that entity. -- --- @since 2.10.0 +-- @since 2.13.0.0 onlyOneUniqueDef :: (OnlyOneUniqueKey record, Monad proxy) => proxy record -> UniqueDef onlyOneUniqueDef prxy = - case entityUniques (entityDef prxy) of + case getEntityUniques (entityDef prxy) of [uniq] -> uniq _ -> error "impossible due to OnlyOneUniqueKey constraint" @@ -319,7 +380,7 @@ 'Text "The entity " ':<>: 'ShowType ty ':<>: 'Text " does not have any unique keys." - ':$$: 'Text "The function you are trying to call requires a unique key " + ':$$: 'Text "The function you are trying to call requires a unique key " ':<>: 'Text "to be defined on the entity." -- | This is an error message. It is used when an entity has multiple @@ -330,9 +391,9 @@ 'Text "The entity " ':<>: 'ShowType ty ':<>: 'Text " has multiple unique keys." - ':$$: 'Text "The function you are trying to call requires only a single " + ':$$: 'Text "The function you are trying to call requires only a single " ':<>: 'Text "unique key." - ':$$: 'Text "There is probably a variant of the function with 'By' " + ':$$: 'Text "There is probably a variant of the function with 'By' " ':<>: 'Text "appended that will allow you to select a unique key " ':<>: 'Text "for the operation." @@ -343,7 +404,7 @@ -- 0 unique keys. -- -- @since 2.10.0 -class PersistEntity record => AtLeastOneUniqueKey record where +class (PersistEntity record) => AtLeastOneUniqueKey record where requireUniquesP :: record -> NonEmpty (Unique record) -- | Given a proxy for a record that has an instance of @@ -356,8 +417,8 @@ => proxy record -> NonEmpty UniqueDef atLeastOneUniqueDef prxy = - case entityUniques (entityDef prxy) of - (x:xs) -> x :| xs + case getEntityUniques (entityDef prxy) of + (x : xs) -> x :| xs _ -> error "impossible due to AtLeastOneUniqueKey record constraint" @@ -376,12 +437,13 @@ -- -- First three lines return 'Left' because there're duplicates in given record's uniqueness constraints. While the last line returns a new key as 'Right'. insertBy - :: - ( MonadIO m - , PersistUniqueWrite backend - , PersistRecordBackend record backend - , AtLeastOneUniqueKey record - ) + :: forall record backend m + . ( MonadIO m + , PersistUniqueWrite backend + , PersistRecordBackend record backend + , AtLeastOneUniqueKey record + , SafeToInsert record + ) => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val @@ -421,14 +483,17 @@ -- > +----+-------+-----+ -- > | 3 | Alexa | 3 | -- > +----+-------+-----+ - insertUniqueEntity - :: (MonadIO m - ,PersistRecordBackend record backend - ,PersistUniqueWrite backend) - => record -> ReaderT backend m (Maybe (Entity record)) + :: forall record backend m + . ( MonadIO m + , PersistRecordBackend record backend + , PersistUniqueWrite backend + , SafeToInsert record + ) + => record + -> ReaderT backend m (Maybe (Entity record)) insertUniqueEntity datum = - fmap (\key -> Entity key datum) `liftM` insertUnique datum + fmap (\key -> Entity key datum) `liftM` insertUnique datum -- | Return the single unique key for a record. -- @@ -445,12 +510,12 @@ -- @onlyUnique@ doesn't work if there're more than two constraints. It will -- fail with a type error instead. onlyUnique - :: - ( MonadIO m - , PersistUniqueWrite backend - , PersistRecordBackend record backend - , OnlyOneUniqueKey record - ) + :: forall record backend m + . ( MonadIO m + , PersistUniqueWrite backend + , PersistRecordBackend record backend + , OnlyOneUniqueKey record + ) => record -> ReaderT backend m (Unique record) onlyUnique = pure . onlyUniqueP @@ -476,15 +541,16 @@ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getByValue - :: forall record m backend. - ( MonadIO m - , PersistUniqueRead backend - , PersistRecordBackend record backend - , AtLeastOneUniqueKey record - ) + :: forall record m backend + . ( MonadIO m + , PersistUniqueRead backend + , PersistRecordBackend record backend + , AtLeastOneUniqueKey record + ) => record -> ReaderT backend m (Maybe (Entity record)) getByValue record = do - let uniqs = requireUniquesP record + let + uniqs = requireUniquesP record getByValueUniques (NEL.toList uniqs) -- | Retrieve a record from the database using the given unique keys. It @@ -496,18 +562,18 @@ -- -- @since 2.10.0 getByValueUniques - :: - ( MonadIO m - , PersistUniqueRead backend - , PersistRecordBackend record backend - ) + :: forall record backend m + . ( MonadIO m + , PersistUniqueRead backend + , PersistRecordBackend record backend + ) => [Unique record] -> ReaderT backend m (Maybe (Entity record)) getByValueUniques uniqs = checkUniques uniqs where checkUniques [] = return Nothing - checkUniques (x:xs) = do + checkUniques (x : xs) = do y <- getBy x case y of Nothing -> checkUniques xs @@ -522,10 +588,12 @@ -- -- @since 1.2.2.0 replaceUnique - :: ( MonadIO m + :: forall record backend m + . ( MonadIO m , Eq (Unique record) , PersistRecordBackend record backend - , PersistUniqueWrite backend ) + , PersistUniqueWrite backend + ) => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where @@ -557,39 +625,125 @@ -- -- > mSpjConst <- checkUnique $ User "SPJ" 60 checkUnique - :: (MonadIO m - ,PersistRecordBackend record backend - ,PersistUniqueRead backend) + :: forall record backend m + . ( MonadIO m + , PersistRecordBackend record backend + , PersistUniqueRead backend + ) => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys checkUniqueKeys - :: (MonadIO m - ,PersistUniqueRead backend - ,PersistRecordBackend record backend) + :: forall record backend m + . ( MonadIO m + , PersistUniqueRead backend + , PersistRecordBackend record backend + ) => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing -checkUniqueKeys (x:xs) = do +checkUniqueKeys (x : xs) = do y <- getBy x case y of Nothing -> checkUniqueKeys xs Just _ -> return (Just x) --- | The slow but generic 'putMany' implemetation for any 'PersistUniqueRead'. +-- | Check whether there are any conflicts for unique keys with this entity and +-- existing entities in the database. +-- +-- Returns 'Nothing' if the entity would stay unique, and could thus safely be updated. +-- on a conflict returns the conflicting key +-- +-- This is similar to 'checkUnique', except it's useful for updating - when the +-- particular entity already exists, it would normally conflict with itself. +-- This variant ignores those conflicts +-- +-- === __Example usage__ +-- +-- We use <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1> here. +-- +-- This would be 'Nothing': +-- +-- > mAlanConst <- checkUnique $ User "Alan" 70 +-- +-- While this would be 'Just' because SPJ already exists: +-- +-- > mSpjConst <- checkUnique $ User "SPJ" 60 +-- +-- @since 2.11.0.0 +checkUniqueUpdateable + :: forall record backend m + . ( MonadIO m + , PersistRecordBackend record backend + , PersistUniqueRead backend + ) + => Entity record -> ReaderT backend m (Maybe (Unique record)) +checkUniqueUpdateable (Entity key record) = + checkUniqueKeysUpdateable key (persistUniqueKeys record) + +checkUniqueKeysUpdateable + :: forall record backend m + . ( MonadIO m + , PersistUniqueRead backend + , PersistRecordBackend record backend + ) + => Key record -> [Unique record] -> ReaderT backend m (Maybe (Unique record)) +checkUniqueKeysUpdateable _ [] = return Nothing +checkUniqueKeysUpdateable key (x : xs) = do + y <- getBy x + case y of + Nothing -> + checkUniqueKeysUpdateable key xs + Just (Entity k _) + | key == k -> + checkUniqueKeysUpdateable key xs + Just _ -> + return (Just x) + +-- | The slow but generic 'upsertBy' implementation for any 'PersistUniqueRead'. +-- * Lookup corresponding entities (if any) 'getBy'. +-- * If the record exists, update using 'updateGet'. +-- * If it does not exist, insert using 'insertEntity'. +-- @since 2.11 +defaultUpsertBy + :: ( PersistEntityBackend record ~ BaseBackend backend + , PersistEntity record + , MonadIO m + , PersistStoreWrite backend + , PersistUniqueRead backend + , SafeToInsert record + ) + => Unique record + -- ^ uniqueness constraint to find by + -> record + -- ^ new record to insert + -> [Update record] + -- ^ updates to perform if the record already exists + -> ReaderT backend m (Entity record) + -- ^ the record in the database after the operation +defaultUpsertBy uniqueKey record updates = do + mrecord <- getBy uniqueKey + maybe (insertEntity record) (`updateGetEntity` updates) mrecord + where + updateGetEntity (Entity k _) upds = + (Entity k) `liftM` (updateGet k upds) + +-- | The slow but generic 'putMany' implementation for any 'PersistUniqueRead'. -- * Lookup corresponding entities (if any) for each record using 'getByValue' -- * For pre-existing records, issue a 'replace' for each old key and new record -- * For new records, issue a bulk 'insertMany_' defaultPutMany - ::( PersistEntityBackend record ~ BaseBackend backend - , PersistEntity record - , MonadIO m - , PersistStoreWrite backend - , PersistUniqueRead backend - ) + :: forall record backend m + . ( PersistEntityBackend record ~ BaseBackend backend + , PersistEntity record + , MonadIO m + , PersistStoreWrite backend + , PersistUniqueRead backend + , SafeToInsert record + ) => [record] -> ReaderT backend m () -defaultPutMany [] = return () -defaultPutMany rsD@(e:_) = do +defaultPutMany [] = return () +defaultPutMany rsD@(e : _) = do case persistUniqueKeys e of [] -> insertMany_ rsD _ -> go @@ -598,30 +752,41 @@ -- deduplicate the list of records in Haskell by unique key. The -- previous implementation used Data.List.nubBy which is O(n^2) -- complexity. - let rs = map snd - . Map.toList - . Map.fromList - . map (\r -> (persistUniqueKeyValues r, r)) - $ rsD + let + rs = + map snd + . Map.toList + . Map.fromList + . map (\r -> (persistUniqueKeyValues r, r)) + $ rsD -- lookup record(s) by their unique key mEsOld <- mapM (getByValueUniques . persistUniqueKeys) rs -- find pre-existing entities and corresponding (incoming) records - let merge (Just x) y = Just (x, y) - merge _ _ = Nothing - let mEsOldAndRs = zipWith merge mEsOld rs - let esOldAndRs = catMaybes mEsOldAndRs + let + merge (Just x) y = Just (x, y) + merge _ _ = Nothing + let + mEsOldAndRs = zipWith merge mEsOld rs + let + esOldAndRs = catMaybes mEsOldAndRs -- determine records to insert - let esOld = fmap fst esOldAndRs - let rsOld = fmap entityVal esOld - let rsNew = deleteFirstsBy ((==) `on` persistUniqueKeyValues) rs rsOld + let + esOld = fmap fst esOldAndRs + let + rsOld = fmap entityVal esOld + let + rsNew = deleteFirstsBy ((==) `on` persistUniqueKeyValues) rs rsOld -- determine records to update - let rsUpd = fmap snd esOldAndRs - let ksOld = fmap entityKey esOld - let krs = zip ksOld rsUpd + let + rsUpd = fmap snd esOldAndRs + let + ksOld = fmap entityKey esOld + let + krs = zip ksOld rsUpd -- insert `new` records insertMany_ rsNew @@ -631,5 +796,5 @@ -- | This function returns a list of 'PersistValue' that correspond to the -- 'Unique' keys on that record. This is useful for comparing two @record@s -- for equality only on the basis of their 'Unique' keys. -persistUniqueKeyValues :: PersistEntity record => record -> [PersistValue] +persistUniqueKeyValues :: (PersistEntity record) => record -> [PersistValue] persistUniqueKeyValues = concatMap persistUniqueToValues . persistUniqueKeys diff --git a/Database/Persist/Compatible.hs b/Database/Persist/Compatible.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Compatible.hs @@ -0,0 +1,8 @@ +module Database.Persist.Compatible + ( Compatible (..) + , makeCompatibleInstances + , makeCompatibleKeyInstances + ) where + +import Database.Persist.Compatible.TH +import Database.Persist.Compatible.Types diff --git a/Database/Persist/Compatible/TH.hs b/Database/Persist/Compatible/TH.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Compatible/TH.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Database.Persist.Compatible.TH + ( makeCompatibleInstances + , makeCompatibleKeyInstances + ) where + +import Data.Aeson +import Database.Persist.Class +import Database.Persist.Sql.Class +import Language.Haskell.TH + +import Database.Persist.Compatible.Types + +-- | Gives a bunch of useful instance declarations for a backend based on its +-- compatibility with another backend, using 'Compatible'. +-- +-- The argument should be a type of the form @ forall v1 ... vn. Compatible b s @ +-- (Quantification is optional, but supported because TH won't let you have +-- unbound type variables in a type splice). The instance is produced for @s@ +-- based on the instance defined for @b@, which is constrained in the instance +-- head to exist. +-- +-- @v1 ... vn@ are implicitly quantified in the instance, which is derived via +-- @'Compatible' b s@. +-- +-- @since 2.12 +makeCompatibleInstances :: Q Type -> Q [Dec] +makeCompatibleInstances compatibleType = do + (b, s) <- + compatibleType >>= \case + ForallT _ _ (AppT (AppT (ConT conTName) b) s) -> + if conTName == ''Compatible + then pure (b, s) + else + fail $ + "Cannot make `deriving via` instances if the argument is " + <> "not of the form `forall v1 ... vn. Compatible sub sup`" + AppT (AppT (ConT conTName) b) s -> + if conTName == ''Compatible + then pure (b, s) + else + fail $ + "Cannot make `deriving via` instances if the argument is " + <> "not of the form `Compatible sub sup`" + _ -> + fail $ + "Cannot make `deriving via` instances if the argument is " + <> "not of the form `Compatible sub sup`" + + [d| + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b)) => HasPersistBackend $(return s) + + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b), PersistStoreRead $(return b)) + => PersistStoreRead $(return s) + + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b), PersistQueryRead $(return b)) + => PersistQueryRead $(return s) + + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b), PersistUniqueRead $(return b)) + => PersistUniqueRead $(return s) + + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b), PersistStoreWrite $(return b)) + => PersistStoreWrite $(return s) + + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b), PersistQueryWrite $(return b)) + => PersistQueryWrite $(return s) + + deriving via + (Compatible $(return b) $(return s)) + instance + (HasPersistBackend $(return b), PersistUniqueWrite $(return b)) + => PersistUniqueWrite $(return s) + |] + +-- | Gives a bunch of useful instance declarations for a backend key based on +-- its compatibility with another backend & key, using 'Compatible'. +-- +-- The argument should be a type of the form @ forall v1 ... vn. Compatible b s @ +-- (Quantification is optional, but supported because TH won't let you have +-- unbound type variables in a type splice). The instance is produced for +-- @'BackendKey' s@ based on the instance defined for @'BackendKey' b@, which +-- is constrained in the instance head to exist. +-- +-- @v1 ... vn@ are implicitly quantified in the instance, which is derived via +-- @'BackendKey' ('Compatible' b s)@. +-- +-- @since 2.12 +makeCompatibleKeyInstances :: Q Type -> Q [Dec] +makeCompatibleKeyInstances compatibleType = do + (b, s) <- + compatibleType >>= \case + ForallT _ _ (AppT (AppT (ConT conTName) b) s) -> + if conTName == ''Compatible + then pure (b, s) + else + fail $ + "Cannot make `deriving via` instances if the argument is " + <> "not of the form `forall v1 ... vn. Compatible sub sup`" + AppT (AppT (ConT conTName) b) s -> + if conTName == ''Compatible + then pure (b, s) + else + fail $ + "Cannot make `deriving via` instances if the argument is " + <> "not of the form `Compatible sub sup`" + _ -> + fail $ + "Cannot make `deriving via` instances if the argument is " + <> "not of the form `Compatible sub sup`" + + [d| + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , Show (BackendKey $(return b)) + ) + => Show (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , Read (BackendKey $(return b)) + ) + => Read (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + (PersistCore $(return b), PersistCore $(return s), Eq (BackendKey $(return b))) + => Eq (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + (PersistCore $(return b), PersistCore $(return s), Ord (BackendKey $(return b))) + => Ord (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + (PersistCore $(return b), PersistCore $(return s), Num (BackendKey $(return b))) + => Num (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , Integral (BackendKey $(return b)) + ) + => Integral (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , PersistField (BackendKey $(return b)) + ) + => PersistField (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , PersistFieldSql (BackendKey $(return b)) + ) + => PersistFieldSql (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , Real (BackendKey $(return b)) + ) + => Real (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , Enum (BackendKey $(return b)) + ) + => Enum (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , Bounded (BackendKey $(return b)) + ) + => Bounded (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , ToJSON (BackendKey $(return b)) + ) + => ToJSON (BackendKey $(return s)) + + deriving via + (BackendKey (Compatible $(return b) $(return s))) + instance + ( PersistCore $(return b) + , PersistCore $(return s) + , FromJSON (BackendKey $(return b)) + ) + => FromJSON (BackendKey $(return s)) + |] diff --git a/Database/Persist/Compatible/Types.hs b/Database/Persist/Compatible/Types.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Compatible/Types.hs @@ -0,0 +1,212 @@ +{- You can't export a data family constructor, so there's an "unused" warning -} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Database.Persist.Compatible.Types + ( Compatible (..) + ) where + +import Control.Monad.Trans.Reader (withReaderT) +import Data.Aeson +import Database.Persist.Class +import Database.Persist.Sql.Class + +-- | A newtype wrapper for compatible backends, mainly useful for @DerivingVia@. +-- +-- When writing a new backend that is 'BackendCompatible' with an existing backend, +-- instances for the new backend can be naturally defined in terms of the +-- instances for the existing backend. +-- +-- For example, if you decide to augment the 'SqlBackend' with some additional +-- features: +-- +-- @ +-- data BetterSqlBackend = BetterSqlBackend { sqlBackend :: SqlBackend, ... } +-- +-- instance BackendCompatible SqlBackend BetterSqlBackend where +-- projectBackend = sqlBackend +-- @ +-- +-- Then you can use @DerivingVia@ to automatically get instances like: +-- +-- @ +-- deriving via (Compatible SqlBackend BetterSqlBackend) instance PersistStoreRead BetterSqlBackend +-- deriving via (Compatible SqlBackend BetterSqlBackend) instance PersistStoreWrite BetterSqlBackend +-- ... +-- @ +-- +-- These instances will go through the compatible backend (in this case, 'SqlBackend') +-- for all their queries. +-- +-- These instances require that both backends have the same 'BaseBackend', but +-- deriving 'HasPersistBackend' will enforce that for you. +-- +-- @ +-- deriving via (Compatible SqlBackend BetterSqlBackend) instance HasPersistBackend BetterSqlBackend +-- @ +-- +-- @since 2.12 +newtype Compatible b s = Compatible {unCompatible :: s} + +instance + (BackendCompatible b s, HasPersistBackend b) + => HasPersistBackend (Compatible b s) + where + type BaseBackend (Compatible b s) = BaseBackend b + persistBackend = persistBackend . projectBackend @b @s . unCompatible + +instance (BackendCompatible b s, PersistCore b) => PersistCore (Compatible b s) where + -- \| A newtype wrapper around @'BackendKey' b@, mainly useful for @DerivingVia@. + -- + -- Similarly to @'Compatible' b s@, this data family instance is handy for deriving + -- instances for @'BackendKey' s@ by defining them in terms of @'BackendKey' b@. + -- + -- + -- For example, if you decide to augment the 'SqlBackend' with some additional + -- features: + -- + -- @ + -- data BetterSqlBackend = BetterSqlBackend { sqlBackend :: SqlBackend, ... } + -- + -- instance PersistCore BetterSqlBackend where + -- newtype BackendKey BetterSqlBackend = BSQLKey { unBSQLKey :: BackendKey (Compatible SqlBackend BetterSqlBackend) } + -- @ + -- + -- Then you can use @DerivingVia@ to automatically get instances like: + -- + -- @ + -- deriving via BackendKey (Compatible SqlBackend BetterSqlBackend) instance Show (BackendKey BetterSqlBackend) + -- ... + -- @ + -- + -- These instances will go through the compatible backend's key (in this case, + -- @'BackendKey' 'SqlBackend'@) for all their logic. + newtype BackendKey (Compatible b s) = CompatibleKey {unCompatibleKey :: BackendKey b} + +instance + (HasPersistBackend b, BackendCompatible b s, PersistStoreRead b) + => PersistStoreRead (Compatible b s) + where + get = withReaderT (projectBackend @b @s . unCompatible) . get + getMany = withReaderT (projectBackend @b @s . unCompatible) . getMany + +instance + (HasPersistBackend b, BackendCompatible b s, PersistQueryRead b) + => PersistQueryRead (Compatible b s) + where + selectSourceRes filts opts = + withReaderT (projectBackend @b @s . unCompatible) $ selectSourceRes filts opts + selectFirst filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectFirst filts opts + selectKeysRes filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectKeysRes filts opts + count = withReaderT (projectBackend @b @s . unCompatible) . count + exists = withReaderT (projectBackend @b @s . unCompatible) . exists + +instance + (HasPersistBackend b, BackendCompatible b s, PersistQueryWrite b) + => PersistQueryWrite (Compatible b s) + where + updateWhere filts updates = withReaderT (projectBackend @b @s . unCompatible) $ updateWhere filts updates + deleteWhere = withReaderT (projectBackend @b @s . unCompatible) . deleteWhere + +instance + (HasPersistBackend b, BackendCompatible b s, PersistUniqueRead b) + => PersistUniqueRead (Compatible b s) + where + getBy = withReaderT (projectBackend @b @s . unCompatible) . getBy + existsBy = withReaderT (projectBackend @b @s . unCompatible) . existsBy + +instance + (HasPersistBackend b, BackendCompatible b s, PersistStoreWrite b) + => PersistStoreWrite (Compatible b s) + where + insert = withReaderT (projectBackend @b @s . unCompatible) . insert + insert_ = withReaderT (projectBackend @b @s . unCompatible) . insert_ + insertMany = withReaderT (projectBackend @b @s . unCompatible) . insertMany + insertMany_ = withReaderT (projectBackend @b @s . unCompatible) . insertMany_ + insertEntityMany = withReaderT (projectBackend @b @s . unCompatible) . insertEntityMany + insertKey k = withReaderT (projectBackend @b @s . unCompatible) . insertKey k + repsert k = withReaderT (projectBackend @b @s . unCompatible) . repsert k + repsertMany = withReaderT (projectBackend @b @s . unCompatible) . repsertMany + replace k = withReaderT (projectBackend @b @s . unCompatible) . replace k + delete = withReaderT (projectBackend @b @s . unCompatible) . delete + update k = withReaderT (projectBackend @b @s . unCompatible) . update k + updateGet k = withReaderT (projectBackend @b @s . unCompatible) . updateGet k + +instance + (HasPersistBackend b, BackendCompatible b s, PersistUniqueWrite b) + => PersistUniqueWrite (Compatible b s) + where + deleteBy = withReaderT (projectBackend @b @s . unCompatible) . deleteBy + insertUnique = withReaderT (projectBackend @b @s . unCompatible) . insertUnique + upsert rec = withReaderT (projectBackend @b @s . unCompatible) . upsert rec + upsertBy uniq rec = withReaderT (projectBackend @b @s . unCompatible) . upsertBy uniq rec + putMany = withReaderT (projectBackend @b @s . unCompatible) . putMany + +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Show (BackendKey b)) + => Show (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Read (BackendKey b)) + => Read (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Eq (BackendKey b)) => Eq (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Ord (BackendKey b)) => Ord (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Num (BackendKey b)) => Num (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Integral (BackendKey b)) + => Integral (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, PersistField (BackendKey b)) + => PersistField (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, PersistFieldSql (BackendKey b)) + => PersistFieldSql (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Real (BackendKey b)) + => Real (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Enum (BackendKey b)) + => Enum (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, Bounded (BackendKey b)) + => Bounded (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, ToJSON (BackendKey b)) + => ToJSON (BackendKey (Compatible b s)) +deriving via + (BackendKey b) + instance + (BackendCompatible b s, FromJSON (BackendKey b)) + => FromJSON (BackendKey (Compatible b s)) diff --git a/Database/Persist/EntityDef.hs b/Database/Persist/EntityDef.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/EntityDef.hs @@ -0,0 +1,228 @@ +-- | An 'EntityDef' represents metadata about a type that @persistent@ uses to +-- store the type in the database, as well as generate Haskell code from it. +-- +-- @since 2.13.0.0 +module Database.Persist.EntityDef + ( -- * The 'EntityDef' type + EntityDef + + -- * Construction + + -- * Accessors + , getEntityHaskellName + , getEntityDBName + , getEntityFields + , getEntityFieldsDatabase + , getEntityForeignDefs + , getEntityUniques + , getEntityUniquesNoPrimaryKey + , getEntityId + , getEntityIdField + , getEntityKeyFields + , getEntityComments + , getEntityExtra + , getEntitySpan + , isEntitySum + , entityPrimary + , entitiesPrimary + , keyAndEntityFields + , keyAndEntityFieldsDatabase + + -- * Setters + , setEntityId + , setEntityIdDef + , setEntityDBName + , overEntityFields + + -- * Related Types + , EntityIdDef (..) + ) where + +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import Data.Text (Text) + +import Database.Persist.EntityDef.Internal +import Database.Persist.FieldDef + +import Database.Persist.Names +import Database.Persist.Types.Base + ( ForeignDef + , SourceSpan + , UniqueDef (..) + , entityKeyFields + ) + +-- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This does not include +-- a @Primary@ key, if one is defined. A future version of @persistent@ will +-- include a @Primary@ key among the 'Unique' constructors for the 'Entity'. +-- +-- @since 2.14.0.0 +getEntityUniquesNoPrimaryKey + :: EntityDef + -> [UniqueDef] +getEntityUniquesNoPrimaryKey ed = + filter isNotPrimaryKey $ entityUniques ed + where + isNotPrimaryKey ud = + let + constraintName = unConstraintNameHS $ uniqueHaskell ud + in + constraintName /= unEntityNameHS (getEntityHaskellName ed) <> "PrimaryKey" + +-- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. As of version 2.14, +-- this will also include the primary key on the entity, if one is defined. If +-- you do not want the primary key, see 'getEntityUniquesNoPrimaryKey'. +-- +-- @since 2.13.0.0 +getEntityUniques + :: EntityDef + -> [UniqueDef] +getEntityUniques = + entityUniques + +-- | Retrieve the Haskell name of the given entity. +-- +-- @since 2.13.0.0 +getEntityHaskellName + :: EntityDef + -> EntityNameHS +getEntityHaskellName = entityHaskell + +-- | Return the database name for the given entity. +-- +-- @since 2.13.0.0 +getEntityDBName + :: EntityDef + -> EntityNameDB +getEntityDBName = entityDB + +getEntityExtra :: EntityDef -> Map Text [[Text]] +getEntityExtra = entityExtra + +-- | +-- +-- @since 2.13.0.0 +setEntityDBName :: EntityNameDB -> EntityDef -> EntityDef +setEntityDBName db ed = ed{entityDB = db} + +getEntityComments :: EntityDef -> Maybe Text +getEntityComments = entityComments + +-- | +-- +-- @since 2.13.0.0 +getEntityForeignDefs + :: EntityDef + -> [ForeignDef] +getEntityForeignDefs = entityForeigns + +-- | Retrieve the list of 'FieldDef' that makes up the fields of the entity. +-- +-- This does not return the fields for an @Id@ column or an implicit @id@. It +-- will return the key columns if you used the @Primary@ syntax for defining the +-- primary key. +-- +-- This does not return fields that are marked 'SafeToRemove' or 'MigrationOnly' +-- - so it only returns fields that are represented in the Haskell type. If you +-- need those fields, use 'getEntityFieldsDatabase'. +-- +-- @since 2.13.0.0 +getEntityFields + :: EntityDef + -> [FieldDef] +getEntityFields = filter isHaskellField . entityFields + +-- | This returns all of the 'FieldDef' defined for the 'EntityDef', including +-- those fields that are marked as 'MigrationOnly' (and therefore only present +-- in the database) or 'SafeToRemove' (and a migration will drop the column if +-- it exists in the database). +-- +-- For all the fields that are present on the Haskell-type, see +-- 'getEntityFields'. +-- +-- @since 2.13.0.0 +getEntityFieldsDatabase + :: EntityDef + -> [FieldDef] +getEntityFieldsDatabase = entityFields + +-- | +-- +-- @since 2.13.0.0 +isEntitySum + :: EntityDef + -> Bool +isEntitySum = entitySum + +-- | +-- +-- @since 2.13.0.0 +getEntityId + :: EntityDef + -> EntityIdDef +getEntityId = entityId + +-- | +-- +-- @since 2.13.0.0 +getEntityIdField :: EntityDef -> Maybe FieldDef +getEntityIdField ed = + case getEntityId ed of + EntityIdField fd -> + pure fd + _ -> + Nothing + +-- | Set an 'entityId' to be the given 'FieldDef'. +-- +-- @since 2.13.0.0 +setEntityId + :: FieldDef + -> EntityDef + -> EntityDef +setEntityId fd = setEntityIdDef (EntityIdField fd) + +-- | +-- +-- @since 2.13.0.0 +setEntityIdDef + :: EntityIdDef + -> EntityDef + -> EntityDef +setEntityIdDef i ed = ed{entityId = i} + +-- | +-- +-- @since 2.13.0.0 +getEntityKeyFields + :: EntityDef + -> NonEmpty FieldDef +getEntityKeyFields = entityKeyFields + +-- | TODO +-- +-- @since 2.13.0.0 +setEntityFields :: [FieldDef] -> EntityDef -> EntityDef +setEntityFields fd ed = ed{entityFields = fd} + +-- | Perform a mapping function over all of the entity fields, as determined by +-- 'getEntityFieldsDatabase'. +-- +-- @since 2.13.0.0 +overEntityFields + :: ([FieldDef] -> [FieldDef]) + -> EntityDef + -> EntityDef +overEntityFields f ed = + setEntityFields (f (getEntityFieldsDatabase ed)) ed + +-- | Gets the 'Source' of the definition of the entity. +-- +-- Note that as of this writing the span covers the entire file or quasiquote +-- where the item is defined due to parsing limitations. This may be changed in +-- a future release to be more accurate. +-- +-- @since 2.15.0.0 +getEntitySpan :: EntityDef -> Maybe SourceSpan +getEntitySpan = entitySpan diff --git a/Database/Persist/EntityDef/Internal.hs b/Database/Persist/EntityDef/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/EntityDef/Internal.hs @@ -0,0 +1,19 @@ +-- | The 'EntityDef' type, fields, and constructor are exported from this +-- module. Breaking changes to the 'EntityDef' type are not reflected in +-- the major version of the API. Please import from +-- "Database.Persist.EntityDef" instead. +-- +-- If you need this module, please file a GitHub issue why. +-- +-- @since 2.13.0.0 +module Database.Persist.EntityDef.Internal + ( EntityDef (..) + , entityPrimary + , entitiesPrimary + , keyAndEntityFields + , keyAndEntityFieldsDatabase + , toEmbedEntityDef + , EntityIdDef (..) + ) where + +import Database.Persist.Types.Base diff --git a/Database/Persist/FieldDef.hs b/Database/Persist/FieldDef.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/FieldDef.hs @@ -0,0 +1,71 @@ +-- | +-- +-- @since 2.13.0.0 +module Database.Persist.FieldDef + ( -- * The 'FieldDef' type + FieldDef + + -- ** Setters + , setFieldAttrs + , overFieldAttrs + , addFieldAttr + + -- ** Helpers + , isFieldNullable + , isFieldMaybe + , isFieldNotGenerated + , isHaskellField + + -- * 'FieldCascade' + , FieldCascade (..) + , renderFieldCascade + , renderCascadeAction + , noCascade + , CascadeAction (..) + ) where + +import Database.Persist.FieldDef.Internal + +import Database.Persist.Types.Base + ( FieldAttr (..) + , FieldType (..) + , IsNullable (..) + , fieldAttrsContainsNullable + , isHaskellField + ) + +-- | Replace the 'FieldDef' 'FieldAttr' with the new list. +-- +-- @since 2.13.0.0 +setFieldAttrs :: [FieldAttr] -> FieldDef -> FieldDef +setFieldAttrs fas fd = fd{fieldAttrs = fas} + +-- | Modify the list of field attributes. +-- +-- @since 2.13.0.0 +overFieldAttrs :: ([FieldAttr] -> [FieldAttr]) -> FieldDef -> FieldDef +overFieldAttrs k fd = fd{fieldAttrs = k (fieldAttrs fd)} + +-- | Add an attribute to the list of field attributes. +-- +-- @since 2.13.0.0 +addFieldAttr :: FieldAttr -> FieldDef -> FieldDef +addFieldAttr fa = overFieldAttrs (fa :) + +-- | Check if the field definition is nullable +-- +-- @since 2.13.0.0 +isFieldNullable :: FieldDef -> IsNullable +isFieldNullable = + fieldAttrsContainsNullable . fieldAttrs + +-- | Check if the field is `Maybe a` +-- +-- @since 2.13.0.0 +isFieldMaybe :: FieldDef -> Bool +isFieldMaybe field = + case fieldType field of + FTApp (FTTypeCon _ "Maybe") _ -> + True + _ -> + False diff --git a/Database/Persist/FieldDef/Internal.hs b/Database/Persist/FieldDef/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/FieldDef/Internal.hs @@ -0,0 +1,14 @@ +-- | TODO: standard Internal moduel boilerplate +-- +-- @since 2.13.0.0 +module Database.Persist.FieldDef.Internal + ( FieldDef (..) + , isFieldNotGenerated + , FieldCascade (..) + , renderFieldCascade + , renderCascadeAction + , noCascade + , CascadeAction (..) + ) where + +import Database.Persist.Types.Base diff --git a/Database/Persist/ImplicitIdDef.hs b/Database/Persist/ImplicitIdDef.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/ImplicitIdDef.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | This module contains types and functions for creating an 'ImplicitIdDef', +-- which allows you to customize the implied ID column that @persistent@ +-- generates. +-- +-- If this module doesn't suit your needs, you may want to import +-- "Database.Persist.ImplicitIdDef.Internal" instead. If you do so, please file +-- an issue on GitHub so we can support your needs. Breaking changes to that +-- module will *not* be accompanied with a major version bump. +-- +-- @since 2.13.0.0 +module Database.Persist.ImplicitIdDef + ( -- * The Type + ImplicitIdDef + + -- * Construction + , mkImplicitIdDef + + -- * Autoincrementing Integer Key + , autoIncrementingInteger + + -- * Getters + + -- * Setters + , setImplicitIdDefMaxLen + , unsafeClearDefaultImplicitId + ) where + +import Language.Haskell.TH + +import Database.Persist.Class (BackendKey) +import Database.Persist.ImplicitIdDef.Internal +import Database.Persist.Names +import Database.Persist.Types.Base + ( FieldType (..) + , SqlType (..) + ) + +-- | This is the default variant. Setting the implicit ID definition to this +-- value should not have any change at all on how entities are defined by +-- default. +-- +-- @since 2.13.0.0 +autoIncrementingInteger :: ImplicitIdDef +autoIncrementingInteger = + ImplicitIdDef + { iidFieldType = \entName -> + FTTypeCon Nothing $ unEntityNameHS entName `mappend` "Id" + , iidFieldSqlType = + SqlInt64 + , iidType = \isMpsGeneric mpsBackendType -> + ConT ''BackendKey + `AppT` if isMpsGeneric + then VarT (mkName "backend") + else mpsBackendType + , iidDefault = + Nothing + , iidMaxLen = + Nothing + } diff --git a/Database/Persist/ImplicitIdDef/Internal.hs b/Database/Persist/ImplicitIdDef/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/ImplicitIdDef/Internal.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | WARNING: This is an @Internal@ module. As such, breaking changes to the API +-- of this module will not have a corresponding major version bump. +-- +-- Please depend on "Database.Persist.ImplicitIdDef" instead. If you can't use +-- that module, please file an issue on GitHub with your desired use case. +-- +-- @since 2.13.0.0 +module Database.Persist.ImplicitIdDef.Internal where + +import Data.Foldable (asum) +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable (eqT) +import Language.Haskell.TH (Type) +import LiftType +import Type.Reflection + +import Database.Persist.Class.PersistField (PersistField) +import Database.Persist.Names +import Database.Persist.Sql.Class +import Database.Persist.Types + +-- | A specification for how the implied ID columns are created. +-- +-- By default, @persistent@ will give each table a default column named @id@ +-- (customizable by 'PersistSettings'), and the column type will be whatever +-- you'd expect from @'BackendKey' yourBackendType@. For The 'SqlBackend' type, +-- this is an auto incrementing integer primary key. +-- +-- You might want to give a different example. A common use case in postgresql +-- is to use the UUID type, and automatically generate them using a SQL +-- function. +-- +-- Previously, you'd need to add a custom @Id@ annotation for each model. +-- +-- > User +-- > Id UUID default="uuid_generate_v1mc()" +-- > name Text +-- > +-- > Dog +-- > Id UUID default="uuid_generate_v1mc()" +-- > name Text +-- > user UserId +-- +-- Now, you can simply create an 'ImplicitIdDef' that corresponds to this +-- declaration. +-- +-- @ +-- newtype UUID = UUID 'ByteString' +-- +-- instance 'PersistField' UUID where +-- 'toPersistValue' (UUID bs) = +-- 'PersistLiteral_' 'Escaped' bs +-- 'fromPersistValue' pv = +-- case pv of +-- PersistLiteral_ Escaped bs -> +-- Right (UUID bs) +-- _ -> +-- Left "nope" +-- +-- instance 'PersistFieldSql' UUID where +-- 'sqlType' _ = 'SqlOther' "UUID" +-- @ +-- +-- With this instance at the ready, we can now create our implicit definition: +-- +-- @ +-- uuidDef :: ImplicitIdDef +-- uuidDef = mkImplicitIdDef \@UUID "uuid_generate_v1mc()" +-- @ +-- +-- And we can use 'setImplicitIdDef' to use this with the 'MkPersistSettings' +-- for our block. +-- +-- @ +-- mkPersist (setImplicitIdDef uuidDef sqlSettings) [persistLowerCase| ... |] +-- @ +-- +-- TODO: either explain interaction with mkMigrate or fix it. see issue #1249 +-- for more details. +-- +-- @since 2.13.0.0 +data ImplicitIdDef = ImplicitIdDef + { iidFieldType :: EntityNameHS -> FieldType + -- ^ The field type. Accepts the 'EntityNameHS' if you want to refer to it. + -- By default, @Id@ is appended to the end of the Haskell name. + -- + -- @since 2.13.0.0 + , iidFieldSqlType :: SqlType + -- ^ The 'SqlType' for the default column. By default, this is 'SqlInt64' to + -- correspond with an autoincrementing integer primary key. + -- + -- @since 2.13.0.0 + , iidType :: Bool -> Type -> Type + -- ^ The Bool argument is whether or not the 'MkPersistBackend' type has the + -- 'mpsGeneric' field set. + -- + -- The 'Type' is the 'mpsBackend' value. + -- + -- The default uses @'BackendKey' 'SqlBackend'@ (or a generic equivalent). + -- + -- @since 2.13.0.0 + , iidDefault :: Maybe Text + -- ^ The default expression for the field. Note that setting this to + -- 'Nothing' is unsafe. see + -- https://github.com/yesodweb/persistent/issues/1247 for more information. + -- + -- With some cases - like the Postgresql @SERIAL@ type - this is safe, since + -- there's an implied default. + -- + -- @since 2.13.0.0 + , iidMaxLen :: Maybe Integer + -- ^ Specify the maximum length for a key column. This is necessary for + -- @VARCHAR@ columns, like @UUID@ in MySQL. MySQL will throw a runtime error + -- if a text or binary column is used in an index without a length + -- specification. + -- + -- @since 2.13.0.0 + } + +-- | Create an 'ImplicitIdDef' based on the 'Typeable' and 'PersistFieldSql' +-- constraints in scope. +-- +-- This function uses the @TypeApplications@ syntax. Let's look at an example +-- that works with Postgres UUIDs. +-- +-- > newtype UUID = UUID Text +-- > deriving newtype PersistField +-- > +-- > instance PersistFieldSql UUID where +-- > sqlType _ = SqlOther "UUID" +-- > +-- > idDef :: ImplicitIdDef +-- > idDef = mkImplicitIdDefTypeable @UUID "uuid_generate_v1mc()" +-- +-- This 'ImplicitIdDef' will generate default UUID columns, and the database +-- will call the @uuid_generate_v1mc()@ function to generate the value for new +-- rows being inserted. +-- +-- If the type @t@ is 'Text' or 'String' then a @max_len@ attribute of 200 is +-- set. To customize this, use 'setImplicitIdDefMaxLen'. +-- +-- @since 2.13.0.0 +mkImplicitIdDef + :: forall t + . (Typeable t, PersistFieldSql t) + => Text + -- ^ The default expression to use for columns. Should be valid SQL in the + -- language you're using. + -> ImplicitIdDef +mkImplicitIdDef def = + ImplicitIdDef + { iidFieldType = \_ -> + fieldTypeFromTypeable @t + , iidFieldSqlType = + sqlType (Proxy @t) + , iidType = + \_ _ -> liftType @t + , iidDefault = + Just def + , iidMaxLen = + -- this follows a special casing behavior that @persistent@ has done + -- for a while now. this keeps folks code from breaking and probably + -- is mostly what people want. + asum + [ 200 <$ eqT @t @Text + , 200 <$ eqT @t @String + ] + } + +-- | Set the maximum length of the implied ID column. This is required for +-- any type where the associated 'SqlType' is a @TEXT@ or @VARCHAR@ sort of +-- thing. +-- +-- @since 2.13.0.0 +setImplicitIdDefMaxLen + :: Integer + -> ImplicitIdDef + -> ImplicitIdDef +setImplicitIdDefMaxLen i iid = iid{iidMaxLen = Just i} + +-- | This function converts a 'Typeable' type into a @persistent@ +-- representation of the type of a field - 'FieldTyp'. +-- +-- @since 2.13.0.0 +fieldTypeFromTypeable :: forall t. (PersistField t, Typeable t) => FieldType +fieldTypeFromTypeable = go (typeRep @t) + where + go :: forall k (a :: k). TypeRep a -> FieldType + go tr = + case tr of + Con tyCon -> + FTTypeCon Nothing $ Text.pack $ tyConName tyCon + App trA trB -> + FTApp (go trA) (go trB) + Fun _ _ -> + error "No functions in field defs." + +-- | Remove the default attribute of the 'ImplicitIdDef' column. This will +-- require you to provide an ID for the model with every insert, using +-- 'insertKey' instead of 'insert', unless the type has some means of getting +-- around that in the migrations. +-- +-- As an example, the Postgresql @SERIAL@ type expands to an autoincrementing +-- integer. Postgres will implicitly create the relevant series and set the +-- default to be @NEXTVAL('series_name')@. A default is therefore unnecessary to +-- use for this type. +-- +-- However, for a @UUID@, postgres *does not* have an implicit default. You must +-- either specify a default UUID generation function, or insert them yourself +-- (again, using 'insertKey'). +-- +-- This function will be deprecated in the future when omiting the default +-- implicit ID column is more fully supported. +-- +-- @since 2.13.0.0 +unsafeClearDefaultImplicitId :: ImplicitIdDef -> ImplicitIdDef +unsafeClearDefaultImplicitId iid = iid{iidDefault = Nothing} diff --git a/Database/Persist/Names.hs b/Database/Persist/Names.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Names.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveLift #-} + +-- | This module contains types and functions for working with and +-- disambiguating database and Haskell names. +-- +-- @since 2.13.0.0 +module Database.Persist.Names where + +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) + +-- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` +-- instance on pre-1.2.4 versions of `text` +import Instances.TH.Lift () + +-- | Convenience operations for working with '-NameDB' types. +-- +-- @since 2.12.0.0 +class DatabaseName a where + escapeWith :: (Text -> str) -> (a -> str) + +-- | A 'FieldNameDB' represents the datastore-side name that @persistent@ +-- will use for a field. +-- +-- @since 2.12.0.0 +newtype FieldNameDB = FieldNameDB {unFieldNameDB :: Text} + deriving (Show, Eq, Read, Ord, Lift) + +-- | @since 2.12.0.0 +instance DatabaseName FieldNameDB where + escapeWith f (FieldNameDB n) = f n + +-- | A 'FieldNameHS' represents the Haskell-side name that @persistent@ +-- will use for a field. +-- +-- @since 2.12.0.0 +newtype FieldNameHS = FieldNameHS {unFieldNameHS :: Text} + deriving (Show, Eq, Read, Ord, Lift) + +-- | An 'EntityNameHS' represents the Haskell-side name that @persistent@ +-- will use for an entity. +-- +-- @since 2.12.0.0 +newtype EntityNameHS = EntityNameHS {unEntityNameHS :: Text} + deriving (Show, Eq, Read, Ord, Lift) + +-- | An 'EntityNameDB' represents the datastore-side name that @persistent@ +-- will use for an entity. +-- +-- @since 2.12.0.0 +newtype EntityNameDB = EntityNameDB {unEntityNameDB :: Text} + deriving (Show, Eq, Read, Ord, Lift) + +instance DatabaseName EntityNameDB where + escapeWith f (EntityNameDB n) = f n + +-- | A 'ConstraintNameDB' represents the datastore-side name that @persistent@ +-- will use for a constraint. +-- +-- @since 2.12.0.0 +newtype ConstraintNameDB = ConstraintNameDB {unConstraintNameDB :: Text} + deriving (Show, Eq, Read, Ord, Lift) + +-- | @since 2.12.0.0 +instance DatabaseName ConstraintNameDB where + escapeWith f (ConstraintNameDB n) = f n + +-- | An 'ConstraintNameHS' represents the Haskell-side name that @persistent@ +-- will use for a constraint. +-- +-- @since 2.12.0.0 +newtype ConstraintNameHS = ConstraintNameHS {unConstraintNameHS :: Text} + deriving (Show, Eq, Read, Ord, Lift) diff --git a/Database/Persist/PersistValue.hs b/Database/Persist/PersistValue.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/PersistValue.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | This module contains an intermediate representation of values before the +-- backends serialize them into explicit database types. +-- +-- @since 2.13.0.0 +module Database.Persist.PersistValue + ( PersistValue (.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific) + , fromPersistValueText + , LiteralType (..) + ) where + +import Control.DeepSeq +import qualified Data.Aeson as A +import Data.Bits (shiftL, shiftR) +import Data.ByteString as BS (ByteString, foldl') +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS8 +import Data.Int (Int64) +import qualified Data.Scientific +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (Day, TimeOfDay, UTCTime) +import qualified Data.Vector as V +import Numeric (readHex, showHex) +import Web.PathPieces (PathPiece (..)) + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as AM +#else +import qualified Data.HashMap.Strict as AM +#endif + +import Web.HttpApiData + ( FromHttpApiData (..) + , ToHttpApiData (..) + , parseUrlPieceMaybe + , readTextData + ) + +-- | A raw value which can be stored in any backend and can be marshalled to +-- and from a 'PersistField'. +data PersistValue + = PersistText Text + | PersistByteString ByteString + | PersistInt64 Int64 + | PersistDouble Double + | PersistRational Rational + | PersistBool Bool + | PersistDay Day + | PersistTimeOfDay TimeOfDay + | PersistUTCTime UTCTime + | PersistNull + | PersistList [PersistValue] + | PersistMap [(Text, PersistValue)] + | -- | Intended especially for MongoDB backend + PersistObjectId ByteString + | -- | Intended especially for PostgreSQL backend for text arrays + PersistArray [PersistValue] + | -- | This constructor is used to specify some raw literal value for the + -- backend. The 'LiteralType' value specifies how the value should be + -- escaped. This can be used to make special, custom types avaialable + -- in the back end. + -- + -- @since 2.12.0.0 + PersistLiteral_ LiteralType ByteString + deriving (Show, Read, Eq, Ord) + +-- | +-- @since 2.14.4.0 +instance NFData PersistValue where + rnf val = case val of + PersistText txt -> rnf txt + PersistByteString bs -> rnf bs + PersistInt64 i -> rnf i + PersistDouble d -> rnf d + PersistRational q -> rnf q + PersistBool b -> rnf b + PersistDay d -> rnf d + PersistTimeOfDay t -> rnf t + PersistUTCTime t -> rnf t + PersistNull -> () + PersistList vals -> rnf vals + PersistMap vals -> rnf vals + PersistObjectId bs -> rnf bs + PersistArray vals -> rnf vals + PersistLiteral_ ty bs -> ty `seq` rnf bs + +-- | A type that determines how a backend should handle the literal. +-- +-- @since 2.12.0.0 +data LiteralType + = -- | The accompanying value will be escaped before inserting into the + -- database. This is the correct default choice to use. + -- + -- @since 2.12.0.0 + Escaped + | -- | The accompanying value will not be escaped when inserting into the + -- database. This is potentially dangerous - use this with care. + -- + -- @since 2.12.0.0 + Unescaped + | -- | The 'DbSpecific' constructor corresponds to the legacy + -- 'PersistDbSpecific' constructor. We need to keep this around because + -- old databases may have serialized JSON representations that + -- reference this. We don't want to break the ability of a database to + -- load rows. + -- + -- @since 2.12.0.0 + DbSpecific + deriving (Show, Read, Eq, Ord) + +-- | This pattern synonym used to be a data constructor for the +-- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded +-- database values could be parsed into their corresponding values. You +-- should not use this, and instead prefer to pattern match on +-- `PersistLiteral_` directly. +-- +-- If you use this, it will overlap a patern match on the 'PersistLiteral_, +-- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to +-- disambiguate between these constructors, pattern match on +-- 'PersistLiteral_' directly. +-- +-- @since 2.12.0.0 +pattern PersistDbSpecific :: ByteString -> PersistValue +pattern PersistDbSpecific bs <- PersistLiteral_ _ bs + where + PersistDbSpecific bs = PersistLiteral_ DbSpecific bs + +-- | This pattern synonym used to be a data constructor on 'PersistValue', +-- but was changed into a catch-all pattern synonym to allow backwards +-- compatiblity with database types. See the documentation on +-- 'PersistDbSpecific' for more details. +-- +-- @since 2.12.0.0 +pattern PersistLiteralEscaped :: ByteString -> PersistValue +pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs + where + PersistLiteralEscaped bs = PersistLiteral_ Escaped bs + +-- | This pattern synonym used to be a data constructor on 'PersistValue', +-- but was changed into a catch-all pattern synonym to allow backwards +-- compatiblity with database types. See the documentation on +-- 'PersistDbSpecific' for more details. +-- +-- @since 2.12.0.0 +pattern PersistLiteral :: ByteString -> PersistValue +pattern PersistLiteral bs <- PersistLiteral_ _ bs + where + PersistLiteral bs = PersistLiteral_ Unescaped bs + +{-# DEPRECATED + PersistDbSpecific + "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." + #-} + +keyToText :: Key -> Text +keyFromText :: Text -> Key +#if MIN_VERSION_aeson(2,0,0) +type Key = K.Key +keyToText = K.toText +keyFromText = K.fromText +#else +type Key = Text +keyToText = id +keyFromText = id +#endif + +instance ToHttpApiData PersistValue where + toUrlPiece val = + case fromPersistValueText val of + Left e -> error $ Text.unpack e + Right y -> y + +instance FromHttpApiData PersistValue where + parseUrlPiece input = + PersistInt64 + <$> parseUrlPiece input + PersistList + <$> readTextData input + PersistText + <$> return input + where + infixl 3 + Left _ y = y + x _ = x + +instance PathPiece PersistValue where + toPathPiece = toUrlPiece + fromPathPiece = parseUrlPieceMaybe + +fromPersistValueText :: PersistValue -> Either Text Text +fromPersistValueText (PersistText s) = Right s +fromPersistValueText (PersistByteString bs) = + Right $ TE.decodeUtf8With lenientDecode bs +fromPersistValueText (PersistInt64 i) = Right $ Text.pack $ show i +fromPersistValueText (PersistDouble d) = Right $ Text.pack $ show d +fromPersistValueText (PersistRational r) = Right $ Text.pack $ show r +fromPersistValueText (PersistDay d) = Right $ Text.pack $ show d +fromPersistValueText (PersistTimeOfDay d) = Right $ Text.pack $ show d +fromPersistValueText (PersistUTCTime d) = Right $ Text.pack $ show d +fromPersistValueText PersistNull = Left "Unexpected null" +fromPersistValueText (PersistBool b) = Right $ Text.pack $ show b +fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" +fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" +fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" +fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text" +fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text" + +instance A.ToJSON PersistValue where + toJSON (PersistText t) = A.String $ Text.cons 's' t + toJSON (PersistByteString b) = A.String $ Text.cons 'b' $ TE.decodeUtf8 $ B64.encode b + toJSON (PersistInt64 i) = A.Number $ fromIntegral i + toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d + toJSON (PersistRational r) = A.String $ Text.pack $ 'r' : show r + toJSON (PersistBool b) = A.Bool b + toJSON (PersistTimeOfDay t) = A.String $ Text.pack $ 't' : show t + toJSON (PersistUTCTime u) = A.String $ Text.pack $ 'u' : show u + toJSON (PersistDay d) = A.String $ Text.pack $ 'd' : show d + toJSON PersistNull = A.Null + toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l + toJSON (PersistMap m) = A.object $ map go m + where + go (k, v) = (keyFromText k, A.toJSON v) + toJSON (PersistLiteral_ litTy b) = + let + encoded = TE.decodeUtf8 $ B64.encode b + prefix = + case litTy of + DbSpecific -> 'p' + Unescaped -> 'l' + Escaped -> 'e' + in + A.String $ Text.cons prefix encoded + toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a + toJSON (PersistObjectId o) = + A.toJSON $ + showChar 'o' $ + showHexLen 8 (bs2i four) $ + showHexLen 16 (bs2i eight) "" + where + (four, eight) = BS8.splitAt 4 o + + -- taken from crypto-api + bs2i :: ByteString -> Integer + bs2i bs = BS.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs + {-# INLINE bs2i #-} + + -- showHex of n padded with leading zeros if necessary to fill d digits + -- taken from Data.BSON + showHexLen :: (Show n, Integral n) => Int -> n -> ShowS + showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n + where + sigDigits 0 = 1 + sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1 + +instance A.FromJSON PersistValue where + parseJSON (A.String t0) = + case Text.uncons t0 of + Nothing -> fail "Null string" + Just ('p', t) -> + either (\_ -> fail "Invalid base64") (return . PersistDbSpecific) $ + B64.decode $ + TE.encodeUtf8 t + Just ('l', t) -> + either (\_ -> fail "Invalid base64") (return . PersistLiteral) $ + B64.decode $ + TE.encodeUtf8 t + Just ('e', t) -> + either (\_ -> fail "Invalid base64") (return . PersistLiteralEscaped) $ + B64.decode $ + TE.encodeUtf8 t + Just ('s', t) -> return $ PersistText t + Just ('b', t) -> + either (\_ -> fail "Invalid base64") (return . PersistByteString) $ + B64.decode $ + TE.encodeUtf8 t + Just ('t', t) -> PersistTimeOfDay <$> readMay t + Just ('u', t) -> PersistUTCTime <$> readMay t + Just ('d', t) -> PersistDay <$> readMay t + Just ('r', t) -> PersistRational <$> readMay t + Just ('o', t) -> + maybe + (fail "Invalid base64") + (return . PersistObjectId . i2bs (8 * 12) . fst) + $ headMay + $ readHex + $ Text.unpack t + Just (c, _) -> fail $ "Unknown prefix: " ++ [c] + where + headMay [] = Nothing + headMay (x : _) = Just x + readMay t = + case reads $ Text.unpack t of + (x, _) : _ -> return x + [] -> fail "Could not read" + + -- taken from crypto-api + -- \|@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8). + i2bs :: Int -> Integer -> ByteString + i2bs l i = + BS.unfoldr + (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) + (l - 8) + {-# INLINE i2bs #-} + parseJSON (A.Number n) = + return $ + if fromInteger (floor n) == n + then PersistInt64 $ floor n + else PersistDouble $ fromRational $ toRational n + parseJSON (A.Bool b) = return $ PersistBool b + parseJSON A.Null = return PersistNull + parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a) + parseJSON (A.Object o) = + fmap PersistMap $ mapM go $ AM.toList o + where + go (k, v) = (,) (keyToText k) <$> A.parseJSON v diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -1,942 +1,940 @@ -{-# LANGUAGE BangPatterns, CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -{-| -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 @persistent-template@ package 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. - -= 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) -@ - -You can specify 1 or more columns in the primary key. - -= 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 -); -@ - -= 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"]] -@ - -= 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." -@ - -Unfortunately, we can't use this to create Haddocks for you, because . -`persistent` backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. - --} -module Database.Persist.Quasi - ( parse - , PersistSettings (..) - , upperCaseSettings - , lowerCaseSettings - , nullable -#if TEST - , Token (..) - , Line' (..) - , preparse - , tokenize - , parseFieldType - , empty - , removeSpaces - , associateLines - , skipEmpty - , LinesWithComments(..) -#endif - ) where - -import Prelude hiding (lines) - -import qualified Data.List.NonEmpty as NEL -import Data.List.NonEmpty (NonEmpty(..)) -import Control.Arrow ((&&&)) -import Control.Monad (msum, mplus) -import Data.Char -import Data.List (find, foldl') -import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) -import Data.Monoid (mappend) -import Data.Text (Text) -import qualified Data.Text as T -import Database.Persist.Types - -data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show - -parseFieldType :: Text -> Either String FieldType -parseFieldType t0 = - case parseApplyFT t0 of - PSSuccess ft t' - | T.all isSpace t' -> Right ft - PSFail err -> Left $ "PSFail " ++ err - other -> Left $ show other - where - parseApplyFT t = - case goMany id t of - PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' - PSSuccess [] _ -> PSFail "empty" - PSFail err -> PSFail err - PSDone -> PSDone - - parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType - parseEnclosed end ftMod t = - let (a, b) = T.break (== end) t - in case parseApplyFT a of - PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of - ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') - (x, y) -> PSFail $ show (b, x, y) - x -> PSFail $ show x - - parse1 t = - case T.uncons t of - Nothing -> PSDone - Just (c, t') - | isSpace c -> parse1 $ T.dropWhile isSpace t' - | c == '(' -> parseEnclosed ')' id t' - | c == '[' -> parseEnclosed ']' FTList t' - | isUpper c -> - let (a, b) = T.break (\x -> isSpace x || x `elem` ("()[]"::String)) t - in PSSuccess (getCon a) b - | otherwise -> PSFail $ show (c, t') - getCon t = - case T.breakOnEnd "." t of - (_, "") -> FTTypeCon Nothing t - ("", _) -> FTTypeCon Nothing t - (a, b) -> FTTypeCon (Just $ T.init a) b - goMany front t = - case parse1 t of - PSSuccess x t' -> goMany (front . (x:)) t' - PSFail err -> PSFail err - PSDone -> PSSuccess (front []) t - -- _ -> - -data PersistSettings = PersistSettings - { psToDBName :: !(Text -> Text) - , psStrictFields :: !Bool - -- ^ Whether fields are by default strict. Default value: @True@. - -- - -- @since 1.2 - , psIdName :: !Text - -- ^ The name of the id column. Default value: @id@ - -- The name of the id column can also be changed on a per-model basis - -- - -- - -- @since 2.0 - } - -defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings -defaultPersistSettings = PersistSettings - { psToDBName = id - , psStrictFields = True - , psIdName = "id" - } - -upperCaseSettings = defaultPersistSettings - -lowerCaseSettings = defaultPersistSettings - { psToDBName = - let go c - | isUpper c = T.pack ['_', toLower c] - | otherwise = T.singleton c - in T.dropWhile (== '_') . T.concatMap go - } - --- | Parses a quasi-quoted syntax into a list of entity definitions. -parse :: PersistSettings -> Text -> [EntityDef] -parse ps = parseLines ps . preparse - -preparse :: Text -> [Line] -preparse = - removeSpaces - . filter (not . empty) - . map tokenize - . T.lines - --- | A token used by the parser. -data Token = Spaces !Int -- ^ @Spaces n@ are @n@ consecutive spaces. - | Token Text -- ^ @Token tok@ is token @tok@ already unquoted. - | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified. - deriving (Show, Eq) - --- | Tokenize a string. -tokenize :: Text -> [Token] -tokenize t - | T.null t = [] - | "-- | " `T.isPrefixOf` t = [DocComment t] - | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. - | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) - | T.head t == '"' = quotes (T.tail t) id - | T.head t == '(' = parens 1 (T.tail t) id - | isSpace (T.head t) = - let (spaces, rest) = T.span isSpace t - in Spaces (T.length spaces) : tokenize rest - - -- support mid-token quotes and parens - | Just (beforeEquals, afterEquals) <- findMidToken t - , not (T.any isSpace beforeEquals) - , Token next : rest <- tokenize afterEquals = - Token (T.concat [beforeEquals, "=", next]) : rest - - | otherwise = - let (token, rest) = T.break isSpace t - in Token token : tokenize rest - where - findMidToken t' = - case T.break (== '=') t' of - (x, T.drop 1 -> y) - | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) - _ -> Nothing - - quotes t' front - | T.null t' = error $ T.unpack $ T.concat $ - "Unterminated quoted string starting with " : front [] - | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') - | T.head t' == '\\' && T.length t' > 1 = - quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) - | otherwise = - let (x, y) = T.break (`elem` ['\\','\"']) t' - in quotes y (front . (x:)) - parens count t' front - | T.null t' = error $ T.unpack $ T.concat $ - "Unterminated parens string starting with " : front [] - | T.head t' == ')' = - if count == (1 :: Int) - then Token (T.concat $ front []) : tokenize (T.tail t') - else parens (count - 1) (T.tail t') (front . (")":)) - | T.head t' == '(' = - parens (count + 1) (T.tail t') (front . ("(":)) - | T.head t' == '\\' && T.length t' > 1 = - parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) - | otherwise = - let (x, y) = T.break (`elem` ['\\','(',')']) t' - in parens count y (front . (x:)) - --- | A string of tokens is empty when it has only spaces. There --- can't be two consecutive 'Spaces', so this takes /O(1)/ time. -empty :: [Token] -> Bool -empty [] = True -empty [Spaces _] = True -empty _ = False - --- | A line. We don't care about spaces in the middle of the --- line. Also, we don't care about the ammount of indentation. -data Line' f - = Line - { lineIndent :: Int - , tokens :: f Text - } - -deriving instance Show (f Text) => Show (Line' f) -deriving instance Eq (f Text) => Eq (Line' f) - -mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g -mapLine k (Line i t) = Line i (k t) - -traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g) -traverseLine k (Line i xs) = Line i <$> k xs - -type Line = Line' [] - --- | Remove leading spaces and remove spaces in the middle of the --- tokens. -removeSpaces :: [[Token]] -> [Line] -removeSpaces = - map toLine - where - toLine (Spaces i:rest) = toLine' i rest - toLine xs = toLine' 0 xs - - toLine' i = Line i . mapMaybe fromToken - - fromToken (Token t) = Just t - fromToken (DocComment t) = Just t - fromToken Spaces{} = Nothing - --- | Divide lines into blocks and make entity definitions. -parseLines :: PersistSettings -> [Line] -> [EntityDef] -parseLines ps lines = - fixForeignKeysAll $ toEnts lines - where - toEnts :: [Line] -> [UnboundEntityDef] - toEnts = - map mk - . associateLines - . skipEmpty - mk :: LinesWithComments -> UnboundEntityDef - mk lwc = - let Line _ (name :| entAttribs) :| rest = lwcLines lwc - in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) - -isComment :: Text -> Maybe Text -isComment xs = - T.stripPrefix "-- | " xs - -data LinesWithComments = LinesWithComments - { lwcLines :: NonEmpty (Line' NonEmpty) - , lwcComments :: [Text] - } deriving (Eq, Show) - --- TODO: drop this and use <> when 8.2 isn't supported anymore so the --- monoid/semigroup nonsense isn't annoying -appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments -appendLwc a b = - LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) - -newLine :: Line' NonEmpty -> LinesWithComments -newLine l = LinesWithComments (pure l) [] - -firstLine :: LinesWithComments -> Line' NonEmpty -firstLine = NEL.head . lwcLines - -consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments -consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } - -consComment :: Text -> LinesWithComments -> LinesWithComments -consComment l lwc = lwc { lwcComments = l : lwcComments lwc } - -associateLines :: [Line' NonEmpty] -> [LinesWithComments] -associateLines lines = - foldr combine [] $ - foldr toLinesWithComments [] lines - where - toLinesWithComments line linesWithComments = - case linesWithComments of - [] -> - [newLine line] - (lwc : lwcs) -> - case isComment (NEL.head (tokens line)) of - Just comment - | lineIndent line == lowestIndent -> - consComment comment lwc : lwcs - _ -> - if lineIndent line <= lineIndent (firstLine lwc) - then - consLine line lwc : lwcs - else - newLine line : lwc : lwcs - - lowestIndent = minimum . fmap lineIndent $ lines - combine :: LinesWithComments -> [LinesWithComments] -> [LinesWithComments] - combine lwc [] = - [lwc] - combine lwc (lwc' : lwcs) = - let minIndent = minimumIndentOf lwc - otherIndent = minimumIndentOf lwc' - in - if minIndent < otherIndent then - appendLwc lwc lwc' : lwcs - else - lwc : lwc' : lwcs - - - minimumIndentOf = minimum . fmap lineIndent . lwcLines - -skipEmpty :: [Line' []] -> [Line' NonEmpty] -skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) - -setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef -setComments [] = id -setComments comments = - overUnboundEntityDef (\ed -> ed { entityComments = Just (T.unlines comments) }) - -fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] -fixForeignKeysAll unEnts = map fixForeignKeys unEnts - where - ents = map unboundEntityDef unEnts - entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents - - fixForeignKeys :: UnboundEntityDef -> EntityDef - fixForeignKeys (UnboundEntityDef foreigns ent) = - ent { entityForeigns = map (fixForeignKey ent) foreigns } - - -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns - fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef - fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) = - let pentError = - error $ "could not find table " ++ show (foreignRefTableHaskell fdef) - ++ " fdef=" ++ show fdef ++ " allnames=" - ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) - ++ "\n\nents=" ++ show ents - pent = - fromMaybe pentError $ M.lookup (foreignRefTableHaskell fdef) entLookup - in - case entityPrimary pent of - Just pdef -> - if length foreignFieldTexts /= length (compositeFields pdef) - then - lengthError pdef - else - let - fds_ffs = - zipWith (toForeignFields pent) - foreignFieldTexts - (compositeFields pdef) - dbname = - unDBName (entityDB pent) - oldDbName = - unDBName (foreignRefTableDBName fdef) - in fdef - { foreignFields = map snd fds_ffs - , foreignNullable = setNull $ map fst fds_ffs - , foreignRefTableDBName = - DBName dbname - , foreignConstraintNameDBName = - DBName - . T.replace oldDbName dbname . unDBName - $ foreignConstraintNameDBName fdef - } - Nothing -> - error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent - where - setNull :: [FieldDef] -> Bool - setNull [] = error "setNull: impossible!" - setNull (fd:fds) = let nullSetting = isNull fd in - if all ((nullSetting ==) . isNull) fds then nullSetting - else error $ "foreign key columns must all be nullable or non-nullable" - ++ show (map (unHaskellName . fieldHaskell) (fd:fds)) - isNull = (NotNullable /=) . nullable . fieldAttrs - - toForeignFields pent fieldText pfd = - case chktypes fd haskellField (entityFields pent) pfh of - Just err -> error err - Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) - where - fd = getFd (entityFields ent) haskellField - - haskellField = HaskellName fieldText - (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) - - chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String - chktypes ffld _fkey pflds pkey = - if fieldType ffld == fieldType pfld then Nothing - else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) - where - pfld = getFd pflds pkey - - entName = entityHaskell ent - getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) - ++ " unknown column: " ++ show t - getFd (f:fs) t - | fieldHaskell f == t = f - | otherwise = getFd fs t - - lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (compositeFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef - - -data UnboundEntityDef = UnboundEntityDef - { _unboundForeignDefs :: [UnboundForeignDef] - , unboundEntityDef :: EntityDef - } - -overUnboundEntityDef - :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef -overUnboundEntityDef f ubed = - ubed { unboundEntityDef = f (unboundEntityDef ubed) } - -lookupKeyVal :: Text -> [Text] -> Maybe Text -lookupKeyVal key = lookupPrefix $ key `mappend` "=" - -lookupPrefix :: Text -> [Text] -> Maybe Text -lookupPrefix prefix = msum . map (T.stripPrefix prefix) - --- | Construct an entity definition. -mkEntityDef :: PersistSettings - -> Text -- ^ name - -> [Attr] -- ^ entity attributes - -> [Line] -- ^ indented lines - -> UnboundEntityDef -mkEntityDef ps name entattribs lines = - UnboundEntityDef foreigns $ - EntityDef - { entityHaskell = entName - , entityDB = DBName $ getDbName ps name' entattribs - -- idField is the user-specified Id - -- otherwise useAutoIdField - -- but, adjust it if the user specified a Primary - , entityId = (setComposite primaryComposite $ fromMaybe autoIdField idField) - , entityAttrs = entattribs - , entityFields = cols - , entityUniques = uniqs - , entityForeigns = [] - , entityDerives = derives - , entityExtra = extras - , entitySum = isSum - , entityComments = comments - } - where - comments = Nothing - entName = HaskellName name' - (isSum, name') = - case T.uncons name of - Just ('+', x) -> (True, x) - _ -> (False, name) - (attribs, extras) = splitExtras lines - - attribPrefix = flip lookupKeyVal entattribs - idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" - | otherwise = Nothing - - (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> - let (i, p, u, f) = takeConstraint ps name' cols attr - squish xs m = xs `mappend` maybeToList m - in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) attribs - - derives = concat $ mapMaybe takeDerives attribs - - cols :: [FieldDef] - cols = reverse . fst . foldr k ([], []) $ reverse attribs - k x (!acc, !comments) = - case isComment =<< listToMaybe x of - Just comment -> - (acc, comment : comments) - Nothing -> - ( maybe id (:) (setFieldComments comments <$> takeColsEx ps x) acc - , [] - ) - setFieldComments [] x = x - setFieldComments xs fld = - fld { fieldComments = Just (T.unlines xs) } - - autoIdField = mkAutoIdField ps entName (DBName `fmap` idName) idSqlType - idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite - - setComposite Nothing fd = fd - setComposite (Just c) fd = fd { fieldReference = CompositeRef c } - - -just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x -just1 (Just x) (Just y) = error $ "expected only one of: " - `mappend` show x `mappend` " " `mappend` show y -just1 x y = x `mplus` y - - -mkAutoIdField :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef -mkAutoIdField ps entName idName idSqlType = FieldDef - { fieldHaskell = HaskellName "Id" - -- this should be modeled as a Maybe - -- but that sucks for non-ID field - -- TODO: use a sumtype FieldDef | IdFieldDef - , fieldDB = fromMaybe (DBName $ psIdName ps) idName - , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName - , fieldSqlType = idSqlType - -- the primary field is actually a reference to the entity - , fieldReference = ForeignRef entName defaultReferenceTypeCon - , fieldAttrs = [] - , fieldStrict = True - , fieldComments = Nothing - } - -defaultReferenceTypeCon :: FieldType -defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" - -keyConName :: Text -> Text -keyConName entName = entName `mappend` "Id" - - -splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]]) -splitExtras [] = ([], M.empty) -splitExtras (Line indent [name]:rest) - | not (T.null name) && isUpper (T.head name) = - let (children, rest') = span ((> indent) . lineIndent) rest - (x, y) = splitExtras rest' - in (x, M.insert name (map tokens children) y) -splitExtras (Line _ ts:rest) = - let (x, y) = splitExtras rest - in (ts:x, y) - -takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef -takeColsEx = - takeCols - (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) - -takeCols - :: (Text -> String -> Maybe FieldDef) - -> PersistSettings - -> [Text] - -> Maybe FieldDef -takeCols _ _ ("deriving":_) = Nothing -takeCols onErr ps (n':typ:rest) - | not (T.null n) && isLower (T.head n) = - case parseFieldType typ of - Left err -> onErr typ err - Right ft -> Just FieldDef - { fieldHaskell = HaskellName n - , fieldDB = DBName $ getDbName ps n rest - , fieldType = ft - , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n - , fieldAttrs = rest - , fieldStrict = fromMaybe (psStrictFields ps) mstrict - , fieldReference = NoReference - , fieldComments = Nothing - } - where - (mstrict, n) - | Just x <- T.stripPrefix "!" n' = (Just True, x) - | Just x <- T.stripPrefix "~" n' = (Just False, x) - | otherwise = (Nothing, n') -takeCols _ _ _ = Nothing - -getDbName :: PersistSettings -> Text -> [Text] -> Text -getDbName ps n [] = psToDBName ps n -getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a - -takeConstraint :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' - where - takeConstraint' - | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing) - | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest) - | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing) - | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing) - | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint -takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) - --- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. --- need to re-work takeCols function -takeId :: PersistSettings -> Text -> [Text] -> FieldDef -takeId ps tableName (n:rest) = fromMaybe (error "takeId: impossible!") $ setFieldDef $ - takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName) - where - field = case T.uncons n of - Nothing -> error "takeId: empty field" - Just (f, ield) -> toLower f `T.cons` ield - addDefaultIdType = takeColsEx ps (field : keyCon : rest `mappend` setIdName) - setFieldDef = fmap (\fd -> - let refFieldType = if fieldType fd == FTTypeCon Nothing keyCon - then defaultReferenceTypeCon - else fieldType fd - in fd { fieldReference = ForeignRef (HaskellName tableName) $ refFieldType - }) - keyCon = keyConName tableName - -- this will be ignored if there is already an existing sql= - -- TODO: I think there is a ! ignore syntax that would screw this up - setIdName = ["sql=" `mappend` psIdName ps] -takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName - - -takeComposite :: [FieldDef] - -> [Text] - -> CompositeDef -takeComposite fields pkcols - = CompositeDef - (map (getDef fields) pkcols) - attrs - where - (_, attrs) = break ("!" `T.isPrefixOf`) pkcols - getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t - getDef (d:ds) t - | fieldHaskell d == HaskellName t = - if nullable (fieldAttrs d) /= NotNullable - then error $ "primary key column cannot be nullable: " ++ show t - else d - | otherwise = getDef ds t - --- Unique UppercaseConstraintName list of lowercasefields terminated --- by ! or sql= such that a unique constraint can look like: --- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` --- Here using sql= sets the name of the constraint. -takeUniq :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UniqueDef -takeUniq ps tableName defs (n:rest) - | not (T.null n) && isUpper (T.head n) - = UniqueDef - (HaskellName n) - dbName - (map (HaskellName &&& getDBName defs) fields) - attrs - where - isAttr a = - "!" `T.isPrefixOf` a - isSqlName a = - "sql=" `T.isPrefixOf` a - isNonField a = - isAttr a - || isSqlName a - (fields, nonFields) = - break isNonField rest - attrs = filter isAttr nonFields - usualDbName = - DBName $ psToDBName ps (tableName `T.append` n) - sqlName :: Maybe DBName - sqlName = - case find isSqlName nonFields of - Nothing -> - Nothing - (Just t) -> - case drop 1 $ T.splitOn "=" t of - (x : _) -> Just (DBName x) - _ -> Nothing - dbName = fromMaybe usualDbName sqlName - getDBName [] t = - error $ "Unknown column in unique constraint: " ++ show t - ++ " " ++ show defs ++ show n ++ " " ++ show attrs - getDBName (d:ds) t - | fieldHaskell d == HaskellName t = fieldDB d - | otherwise = getDBName ds t -takeUniq _ tableName _ xs = - error $ "invalid unique constraint on table[" - ++ show tableName - ++ "] expecting an uppercase constraint name xs=" - ++ show xs - -data UnboundForeignDef = UnboundForeignDef - { _unboundFields :: [Text] -- ^ fields in other entity - , _unboundForeignDef :: ForeignDef - } - -takeForeign :: PersistSettings - -> Text - -> [FieldDef] - -> [Text] - -> UnboundForeignDef -takeForeign ps tableName _defs (refTableName:n:rest) - | not (T.null n) && isLower (T.head n) - = UnboundForeignDef fields $ ForeignDef - { foreignRefTableHaskell = - HaskellName refTableName - , foreignRefTableDBName = - DBName $ psToDBName ps refTableName - , foreignConstraintNameHaskell = - HaskellName n - , foreignConstraintNameDBName = - DBName $ psToDBName ps (tableName `T.append` n) - , foreignFields = - [] - , foreignAttrs = - attrs - , foreignNullable = - False - } - where - (fields,attrs) = break ("!" `T.isPrefixOf`) rest - -takeForeign _ tableName _ xs = error $ "invalid foreign key constraint on table[" ++ show tableName ++ "] expecting a lower case constraint name xs=" ++ show xs - -takeDerives :: [Text] -> Maybe [Text] -takeDerives ("deriving":rest) = Just rest -takeDerives _ = Nothing - -nullable :: [Text] -> IsNullable -nullable s - | "Maybe" `elem` s = Nullable ByMaybeAttr - | "nullable" `elem` s = Nullable ByNullableAttr - | otherwise = NotNullable +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities. +-- +-- The basic structure of the syntax looks like this: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField Int Maybe +-- +-- You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type. +-- +-- @persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL: +-- +-- > CREATE TABLE table_name ( +-- > id SERIAL PRIMARY KEY, +-- > field_name field_type NOT NULL, +-- > other_field varchar NOT NULL, +-- > nullable_field int NULL +-- > ); +-- +-- Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function. +-- +-- It generates a Haskell datatype with the following form: +-- +-- @ +-- data TableName = TableName +-- { tableNameFieldName :: FieldType +-- , tableNameOtherField :: String +-- , tableNameNullableField :: Maybe Int +-- } +-- @ +-- +-- As with the SQL generated, the specifics of this are customizable. +-- See the "Database.Persist.TH" module for details. +-- +-- = Deriving +-- +-- You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that. +-- Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses. +-- +-- > User +-- > name String +-- > age Int +-- > deriving Eq Show +-- > deriving Ord +-- +-- = Unique Keys +-- +-- You can define a uniqueness key on a table with the following format: +-- +-- > User +-- > name String +-- > age Int +-- > +-- > UniqueUserName name +-- +-- This will put a unique index on the @user@ table and the @name@ field. +-- +-- = Setting defaults +-- +-- You can use a @default=${sql expression}@ clause to set a default for a field. +-- The thing following the @=@ is interpreted as SQL that will be put directly into the table definition. +-- +-- @ +-- User +-- name Text +-- admin Bool default=false +-- @ +-- +-- This creates a SQL definition like this: +-- +-- > CREATE TABLE user ( +-- > id SERIAL PRIMARY KEY, +-- > name VARCHAR NOT NULL, +-- > admin BOOL DEFAULT=false +-- > ); +-- +-- A restriction here is that you still need to provide a value when performing an @insert@, because the generated Haskell type has the form: +-- +-- @ +-- data User = User +-- { userName :: Text +-- , userAdmin :: Bool +-- } +-- @ +-- +-- You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default. +-- +-- __Note__: Persistent determines whether or not to migrate a column's default +-- value by comparing the exact string found in your @models@ file with the one +-- returned by the database. If a database canonicalizes the SQL @FALSE@ from your +-- @models@ file to @false@ in the database, Persistent will think the default +-- value needs to be migrated and +-- . +-- +-- To workaround this, find the exact SQL your DBMS uses for the default value. For example, using postgres: +-- +-- @ +-- psql database_name # Open postgres +-- +-- \\d+ table_name -- describe the table schema +-- @ +-- +-- @ +-- ... +-- created | timestamp without time zone | not null default now() +-- @ +-- +-- Then use the listed default value SQL inside your @models@ file. +-- +-- = Custom ID column +-- +-- If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field. +-- This @User@ has a @Text@ ID. +-- +-- > User +-- > Id Text +-- > name Text +-- > age Int +-- +-- If you do this, it's a good idea to set a default for the ID. +-- Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts. +-- +-- @ +-- 'insertKey' (UserKey "Hello world!") (User "Bob" 32) +-- @ +-- +-- If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore. +-- So instead just use a default expression, like this: +-- +-- @ +-- User +-- Id Text default=generate_user_id() +-- name Text +-- age Int +-- @ +-- +-- = Custom Primary Keys +-- +-- Sometimes you don't want to have an ID column, and you want a different sort of primary key. +-- This is a table that stores unique email addresses, and the email is the primary key. +-- We store the first and second part (eg @first\@second@) separately. +-- +-- @ +-- Email +-- firstPart Text +-- secondPart Text +-- +-- Primary firstPart secondPart +-- @ +-- +-- This creates a table with the following form: +-- +-- @ +-- CREATE TABLE email ( +-- first_part varchar, +-- second_part varchar, +-- +-- PRIMARY KEY (first_part, second_part) +-- @ +-- +-- Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo. +-- As a key with multiple fields, it is also a "composite key." +-- +-- You can specify a @Primary@ key with a single field, too. +-- +-- = Overriding SQL +-- +-- You can use a @sql=custom@ annotation to provide some customization on the entity and field. +-- For example, you might prefer to name a table differently than what @persistent@ will do by default. +-- You may also prefer to name a field differently. +-- +-- @ +-- User sql=big_user_table +-- fullName String sql=name +-- age Int +-- @ +-- +-- This will alter the generated SQL to be: +-- +-- @ +-- CREATE TABLE big_user_table ( +-- id SERIAL PRIMARY KEY, +-- name VARCHAR, +-- age INT +-- ); +-- @ +-- +-- = Customizing Types/Tables +-- +-- == JSON instances +-- +-- You can automatically get ToJSON and FromJSON instances for any entity by adding @json@ to the entity line: +-- +-- @ +-- Person json +-- name Text +-- @ +-- Requires @\{\-\# LANGUAGE FlexibleInstances \#\-\}@ +-- +-- Customizable by using mpsEntityJSON +-- * http://hackage.haskell.org/package/persistent-template/docs/Database-Persist-TH.html#v:EntityJSON +-- * http://hackage.haskell.org/package/persistent/docs/Database-Persist-Class.html#v:keyValueEntityToJSON +-- +-- == Changing table/collection name +-- +-- @ +-- Person sql=peoples +-- name Text +-- @ +-- +-- == Change table/collection key definition (field name and\/or type, persistent >= 2.1) +-- +-- @Id@ defines the column to use to define the key of the entity. +-- Without type, the default backend key type will be used. You can change its +-- database name using the @sql@ attributes : +-- +-- @ +-- Person +-- Id sql=my_id_name +-- phone Text +-- @ +-- +-- With a Haskell type, the corresponding type is used. Note that you'll need to +-- use @default=@ to tell it what to do on insertion. +-- +-- @ +-- Person +-- Id Day default=CURRENT_DATE +-- phone Text +-- @ +-- +-- @default=@ works for SQL databases, and is backend specific. +-- For MongoDB currently one always needs to create the key on the application +-- side and use @insertKey@. @insert@ will not work correctly. Sql backends can +-- also do this if default does not work. +-- +-- @sqltype@ can also be used to specify a different database type +-- +-- @ +-- Currency +-- Id String sqltype=varchar(3) sql=code +-- @ +-- +-- Composite key (using multiple columns) can also be defined using @Primary@. +-- +-- @sql=@ also works for setting the names of unique indexes. +-- +-- @ +-- Person +-- name Text +-- phone Text +-- UniquePersonPhone phone sql=UniqPerPhone +-- @ +-- +-- This makes a unique index requiring @phone@ to be unique across @Person@ rows. +-- Ordinarily Persistent will generate a snake-case index name from the +-- capitalized name provided such that @UniquePersonPhone@ becomes +-- @unique_person_phone@. However, we provided a @sql=@ so the index name in the +-- database will instead be @UniqPerPhone@. Keep in mind @sql=@ and @!@ attrs must +-- come after the list of fields in front of the index name in the quasi-quoter. +-- +-- +-- +-- = Customizing Fields +-- +-- == Nullable Fields +-- +-- As illustrated in the example at the beginning of this page, we are able to represent nullable +-- fields by including 'Maybe' at the end of the type declaration: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField Int Maybe +-- +-- Alternatively we can specify the keyword nullable: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField Int nullable +-- +-- However the difference here is in the first instance the Haskell type will be 'Maybe Int', +-- but in the second it will be 'Int'. Be aware that this will cause runtime errors if the +-- database returns @NULL@ and the @PersistField@ instance does not handle @PersistNull@. +-- +-- If you wish to define your Maybe types in a way that is similar to the actual Haskell +-- definition, you can define 'Maybe Int' like so: +-- +-- > TableName +-- > fieldName FieldType +-- > otherField String +-- > nullableField (Maybe Int) +-- +-- However, note, the field _must_ be enclosed in parenthesis. +-- +-- == @sqltype=@ +-- +-- By default, Persistent maps the Haskell types you specify in the Models DSL to +-- an appropriate SQL type in the database (refer to the section "Conversion table +-- (migrations)" for the default mappings). Using the +-- @sqltype=@ option, you can customize the SQL type Persistent uses for your +-- column. Use cases include: +-- +-- * Interacting with an existing database whose column types don't match Persistent's defaults. +-- * Taking advantage of a specific SQL type's features +-- * e.g. Using an equivalent type that has better space or performance characteristics +-- +-- To use this setting, add the @sqltype=@ option after declaring your field name and type: +-- +-- @ +-- User +-- username Text sqltype=varchar(255) +-- @ +-- +-- == Laziness +-- +-- By default the records created by persistent have strict fields. You can prefix +-- a field name with @~@ to make it lazy (or @!@ to make it strict). +-- +-- == Attributes +-- +-- The QuasiQuoter allows you to provide arbitrary attributes to an entity or field. +-- This can be used to extend the code in ways that the library hasn't anticipated. +-- If you use this feature, we'd definitely appreciate hearing about it and +-- potentially supporting your use case directly! +-- +-- @ +-- User !funny +-- field String !sad +-- good Dog !sogood +-- @ +-- +-- We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field. +-- +-- @ +-- userAttrs = do +-- let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User) +-- let userAttributes = 'entityAttrs' userDefinition +-- let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition) +-- print userAttributes +-- -- ["funny"] +-- print fieldAttributes +-- -- [["sad"],["sogood"]] +-- @ +-- +-- == @!no-migrate@ +-- +-- To prevent @migrateModels@ from generating _any_ migrations for an entity, add +-- the @!no-migrate@ attribute to it's definition: +-- +-- @ +-- User !no-migrate +-- field String +-- good Dog +-- @ +-- +-- == @MigrationOnly@ +-- +-- Introduced with @persistent-template@ 1.2.0. The purpose of this attribute is +-- to mark a field which will be entirely ignored by the normal processing, but +-- retained in the database definition for purposes of migration. This means, in +-- SQL, a column will not be flagged for removal by the migration scripts, even +-- though it is not used in your code. This is useful for phasing out usage of a +-- column before entirely removing it, or having columns which are needed by other +-- tools but not by Persistent. +-- +-- @ +-- Person +-- name Text +-- age Int +-- unusedField ByteString Maybe MigrationOnly +-- @ +-- +-- Note that you almost certainly want to either mark the field as @Maybe@ or +-- provide a default value, otherwise insertions will fail. +-- +-- +-- == @SafeToRemove@ +-- +-- This is intended to be used as part of a deprecation of a field, after +-- @MigrationOnly@ has been used usually. This works somewhat as a superset of the +-- functionality of @MigrationOnly@. In addition, the field will be removed from +-- the database if it is present. Note that this is a destructive change which you +-- are marking as safe. +-- +-- == Constraints +-- +-- Migration will remove any manual constraints from your tables. Exception: constraints whose names begin with the string @__manual_@ (which starts with two underscores) will be preserved. +-- +-- +-- = Foreign Keys +-- +-- If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly. +-- +-- @ +-- Person +-- name Text +-- +-- Dog +-- name Text +-- owner PersonId +-- @ +-- +-- This automatically creates a foreign key reference from @Dog@ to @Person@. +-- The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database. +-- If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred. +-- +-- == @constraint=@ +-- +-- You can use the @constraint=@ attribute to override the constraint name used in +-- migrations. This is useful particularly when the automatically generated +-- constraint names exceed database limits (e.g. MySQL does not allow constraint +-- names longer than 64 characters). +-- +-- @ +-- VeryLongTableName +-- name Text +-- +-- AnotherVeryLongTableName +-- veryLongTableNameId VeryLongTableNameId constraint=short_foreign_key +-- @ +-- +-- == OnUpdate and OnDelete +-- +-- These options affects how a referring record behaves when the target record is changed. +-- There are several options: +-- +-- * 'Restrict' - This is the default. It prevents the action from occurring. +-- * 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too. +-- * 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys. +-- * 'SetDefault' - This will set the column's value to the @default@ for the column, if specified. +-- +-- To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action. +-- +-- @ +-- Record +-- -- If the referred Foo is deleted or updated, then this record will +-- -- also be deleted or updated. +-- fooId FooId OnDeleteCascade OnUpdateCascade +-- +-- -- If the referred Bar is deleted, then we'll set the reference to +-- -- 'Nothing'. If the referred Bar is updated, then we'll cascade the +-- -- update. +-- barId BarId Maybe OnDeleteSetNull OnUpdateCascade +-- +-- -- If the referred Baz is deleted, then we set to the default ID. +-- bazId BazId OnDeleteSetDefault default=1 +-- @ +-- +-- Let's demonstrate this with a shopping cart example. +-- +-- @ +-- User +-- name Text +-- +-- Cart +-- user UserId Maybe +-- +-- CartItem +-- cartId CartId +-- itemId ItemId +-- +-- Item +-- name Text +-- price Int +-- @ +-- +-- Let's consider how we want to handle deletions and updates. +-- If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@. +-- +-- @ +-- Cart +-- user UserId Maybe OnDeleteCascade OnUpdateCascade +-- @ +-- +-- If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database. +-- If a @Cart@ is deleted, though, then we just want to delete the @CartItem@. +-- +-- @ +-- CartItem +-- cartId CartId OnDeleteCascade +-- itemId ItemId OnDeleteSetDefault default=1 +-- @ +-- +-- == @Foreign@ keyword +-- +-- The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword. +-- +-- A pseudo formal syntax for @Foreign@ is: +-- +-- @ +-- Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] +-- +-- columns := column0 [column1 column2 .. columnX] +-- references := References $(target-columns) +-- target-columns := target-column0 [target-column1 target-columns2 .. target-columnX] +-- @ +-- +-- Columns are the columns as defined on this entity. +-- @target-columns@ are the columns as defined on the target entity. +-- +-- Let's look at some examples. +-- +-- === Composite Primary Key References +-- +-- The most common use for this is to refer to a composite primary key. +-- Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column. +-- +-- @ +-- Email +-- firstPart Text +-- secondPart Text +-- Primary firstPart secondPart +-- +-- User +-- name Text +-- emailFirstPart Text +-- emailSecondPart Text +-- +-- Foreign Email fk_user_email emailFirstPart emailSecondPart +-- @ +-- +-- If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key. +-- If we wanted to be fully redundant, we could specify the @References@ keyword. +-- +-- @ +-- Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart +-- @ +-- +-- We can specify delete/cascade behavior directly after the target table. +-- +-- @ +-- Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart +-- @ +-- +-- Now, if the email is deleted or updated, the user will be deleted or updated to match. +-- +-- === Non-Primary Key References +-- +-- SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. +-- Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent. +-- To do this, we must use the @References@ keyword. +-- +-- @ +-- User +-- name Text +-- email Text +-- +-- UniqueEmail email +-- +-- Notification +-- content Text +-- sentTo Text +-- +-- Foreign User fk_noti_user sentTo References email +-- @ +-- +-- If the target uniqueness constraint has multiple columns, then you must specify them independently. +-- +-- @ +-- User +-- name Text +-- emailFirst Text +-- emailSecond Text +-- +-- UniqueEmail emailFirst emailSecond +-- +-- Notification +-- content Text +-- sentToFirst Text +-- sentToSecond Text +-- +-- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond +-- @ +-- +-- = Documentation Comments +-- +-- The quasiquoter supports ordinary comments with @--@ and @#@. +-- Since @persistent-2.10.5.1@, it also supports documentation comments. +-- The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions: +-- +-- 1. Only the @-- | @ form is allowed. +-- 2. You must put a space before and after the @|@ pipe character. +-- 3. The comment must be indented at the same level as the entity or field it documents. +-- +-- An example of the field documentation is: +-- +-- @ +-- -- | I am a doc comment for a User. Users are important +-- -- | to the application, and should be treasured. +-- User +-- -- | Users have names. Call them by names. +-- name String +-- -- | A user can be old, or young, and we care about +-- -- | this for some reason. +-- age Int +-- @ +-- +-- The documentation is present on the @entityComments@ field on the @EntityDef@ for the entity: +-- +-- @ +-- >>> let userDefinition = entityDef (Proxy :: Proxy User) +-- >>> entityComments userDefinition +-- "I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n" +-- @ +-- +-- Likewise, the field documentation is present in the @fieldComments@ field on the @FieldDef@ present in the @EntityDef@: +-- +-- @ +-- >>> let userFields = entityFields userDefinition +-- >>> let comments = map fieldComments userFields +-- >>> mapM_ putStrLn comments +-- "Users have names. Call them by names." +-- "A user can be old, or young, and we care about\nthis for some reason." +-- @ +-- +-- Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False). +-- @persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. +-- +-- = Sum types +-- +-- == Field level +-- +-- You'll frequently want to store an enum of values in your database. For +-- example, you might describe a @Person@'s employment status as being @Employed@, +-- @Unemployed@, or @Retired@. In Haskell this is represented with a sum type, and +-- Persistent provides a Template Haskell function to marshall these values to and +-- from the database: +-- +-- @ +-- -- @Employment.hs +-- {-# LANGUAGE TemplateHaskell #-} +-- module Employment where +-- +-- import Database.Persist.TH +-- import Prelude +-- +-- data Employment = Employed | Unemployed | Retired +-- deriving (Show, Read, Eq) +-- derivePersistField "Employment" +-- @ +-- +-- @derivePersistField@ stores sum type values as strins in the database. While not as efficient as using integers, this approach simplifies adding and removing values from your enumeration. +-- +-- Due to the GHC Stage Restriction, the call to the Template Haskell function @derivePersistField@ must be in a separate module than where the generated code is used. +-- +-- Note: If you created a new module, make sure add it to the @exposed-modules@ section of your Cabal file. +-- +-- Use the module by importing it into your @Model.hs@ file: +-- +-- @ +-- -- @Model.hs +-- import Employment +-- @ +-- +-- and use it in the @models@ DSL: +-- +-- @ +-- Person +-- employment Employment +-- @ +-- +-- You can export the Employment module from Import to use it across your app: +-- +-- @ +-- -- @Import.hs +-- import Employment as Import +-- @ +-- +-- === Entity-level +-- +-- NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints). +-- +-- The +-- +-- demonstrate their usage. Note the use of the sign @+@ in front of the entity +-- name. +-- +-- The schema in the test is reproduced here: +-- +-- @ +-- share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase| +-- Bicycle +-- brand T.Text +-- Car +-- make T.Text +-- model T.Text +-- +Vehicle +-- bicycle BicycleId +-- car CarId +-- |] +-- @ +-- +-- Let's check out the definition of the Haskell type @Vehicle@. +-- Using @ghci@, we can query for @:info Vehicle@: +-- +-- >>> :i Vehicle +-- type Vehicle = VehicleGeneric SqlBackend +-- -- Defined at .../Projects/persistent/persistent-test/src/SumTypeTest.hs:26:1 +-- +-- >>> :i VehicleGeneric +-- type role VehicleGeneric nominal +-- data VehicleGeneric backend +-- = VehicleBicycleSum (Key (BicycleGeneric backend)) +-- | VehicleCarSum (Key (CarGeneric backend)) +-- -- Defined at .../persistent/persistent-test/src/SumTypeTest.hs:26:1 +-- -- lots of instances follow... +-- +-- A @VehicleGeneric@ has two constructors: +-- +-- - @VehicleBicycleSum@ with a @Key (BicycleGeneric backend)@ field +-- - @VehicleCarSum@ with a @Key (CarGeneric backend)@ field +-- +-- The @Bicycle@ and @Car@ are typical @persistent@ entities. +-- +-- This generates the following SQL migrations (formatted for readability): +-- +-- @ +-- CREATE TABLE "bicycle" ( +-- "id" INTEGER PRIMARY KEY, +-- "brand" VARCHAR NOT NULL +-- ); +-- +-- CREATE TABLE "car"( +-- "id" INTEGER PRIMARY KEY, +-- "make" VARCHAR NOT NULL, +-- "model" VARCHAR NOT NULL +-- ); +-- +-- CREATE TABLE "vehicle"( +-- "id" INTEGER PRIMARY KEY, +-- "bicycle" INTEGER NULL REFERENCES "bicycle", +-- "car" INTEGER NULL REFERENCES "car" +-- ); +-- @ +-- +-- The @vehicle@ table contains a nullable foreign key reference to both the bicycle and the car tables. +-- +-- A SQL query that grabs all the vehicles from the database looks like this (note the @??@ is for the @persistent@ raw SQL query functions): +-- +-- @ +-- SELECT ??, ??, ?? +-- FROM vehicle +-- LEFT JOIN car +-- ON vehicle.car = car.id +-- LEFT JOIN bicycle +-- ON vehicle.bicycle = bicycle.id +-- @ +-- +-- If we use the above query with @rawSql@, we'd get the following result: +-- +-- @ +-- getVehicles +-- :: SqlPersistM +-- [ ( Entity Vehicle +-- , Maybe (Entity Bicycle) +-- , Maybe (Entity Car) +-- ) +-- ] +-- @ +-- +-- This result has some post-conditions that are not guaranteed by the types *or* the schema. +-- The constructor for @Entity Vehicle@ is going to determine which of the other members of the tuple is @Nothing@. +-- We can convert this to a friendlier domain model like this: +-- +-- @ +-- data Vehicle' +-- = Car' Text Text +-- | Bike Text +-- +-- check = do +-- result <- getVehicles +-- pure (map convert result) +-- +-- convert +-- :: (Entity Vehicle, Maybe (Entity Bicycle), Maybe (Entity Car)) +-- -> Vehicle' +-- convert (Entity _ (VehicleBicycleSum _), Just (Entity _ (Bicycle brand)), _) = +-- Bike brand +-- convert (Entity _ (VehicleCarSum _), _, Just (Entity _ (Car make model))) = +-- Car make model +-- convert _ = +-- error "The database preconditions have been violated!" +-- @ +-- +-- == Times with timezones +-- +-- Storing times with timezones in one type in databases is not possible, although +-- it seems that it should be possible (@timezone@ and @timezonetz@ in +-- PostgreSQL). That's why starting with persistent 2.0, all times will be mapped +-- to @UTCTime@. If you need to store timezone information along with times in a +-- database, store the timezone in a second field. Here are some links about the +-- topic with further information: +-- +-- * https://github.com/yesodweb/persistent/issues/290 +-- * https://groups.google.com/forum/#!msg/yesodweb/MIfcV2bwM80/8QLFpgp1LykJ +-- * http://stackoverflow.com/questions/14615271/postgres-timestamp/14616640#14616640 +-- * http://justatheory.com/computers/databases/postgresql/use-timestamptz.html +-- * https://github.com/lpsmith/postgresql-simple/issues/69 +-- * https://github.com/nikita-volkov/hasql-postgres/issues/1 +-- +-- = Conversion table (migrations) +-- +-- Here are the conversions between Haskell types and database types: +-- +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Haskell | PostgreSQL | MySQL | MongoDB | SQLite | +-- +============+======================+===================+===============+================+ +-- | Text | VARCHAR | TEXT | String | VARCHAR | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | ByteString | BYTEA | BLOB | BinData | BLOB | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Int | INT8 | BIGINT(20) | NumberLong | INTEGER | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Double | DOUBLE PRECISION | DOUBLE | Double | REAL | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Rational | NUMERIC(22, 12) | DECIMAL(32,20) | *Unsupported* | NUMERIC(32,20)| +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Bool | BOOLEAN | TINYINT(1) | Boolean | BOOLEAN | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | Day | DATE | DATE | NumberLong | DATE | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | TimeOfDay | TIME | TIME\*\* | *Unsupported* | TIME | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- | UTCTime\* | TIMESTAMP | DATETIME\*\* | Date | TIMESTAMP | +-- +------------+----------------------+-------------------+---------------+----------------+ +-- +-- Notes: +-- +-- \* Support for @ZonedTime@ was dropped in persistent 2.0. @UTCTime@ can be used +-- with @timestamp without timezone@ and @timestamp with timezone@ in PostgreSQL. +-- See also the section "Times with timezones". +-- +-- \*\* The default resolution for @TIME@ and @DATETIME@ in MySQL is one second. +-- As of MySQL version 5.6.4, and persistent-mysql-2.6.2, fractional seconds are +-- handled correctly if you declare an explicit precision by using @sqltype@. For +-- example, appending @sqltype=TIME(6)@ to a @TimeOfDay@ field definition will +-- give microsecond resolution. +-- +-- = Compatibility tables +-- +-- MySQL: +-- +-- +-------------------+-----------------------------------------------------------------------+ +-- |Haskell type | Compatible MySQL types | +-- +===================+=======================================================================+ +-- | Bool | Tiny | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int8 | Tiny | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int16 | Tiny,Short | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int32 | Tiny,Short,Int24,Long | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int | Tiny,Short,Int24,Long,LongLong\* | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Int64 | Tiny,Short,Int24,Long,LongLong | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Integer | Tiny,Short,Int24,Long,LongLong | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word8 | Tiny | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word16 | Tiny,Short | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word32 | Tiny,Short,Int24,Long | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Word64 | Tiny,Short,Int24,Long,LongLong | +-- | Double | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Ratio Integer | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long,LongLong | +-- +-------------------+-----------------------------------------------------------------------+ +-- | ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Lazy.ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Encoding.Text\*\* | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Lazy.Text | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | [Char]/String | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-- +-------------------+-----------------------------------------------------------------------+ +-- | UTCTime | DateTime,Timestamp | +-- +-------------------+-----------------------------------------------------------------------+ +-- | Day | Year,Date,NewDate | +-- +-------------------+-----------------------------------------------------------------------+ +-- | TimeOfDay | Time | +-- +-------------------+-----------------------------------------------------------------------+ +-- +-- \* When @Word@ size is 64bit +-- +-- \*\* Utf8 only +-- +-- Unsupported types: +-- +-- +--------------------------------------------------------------------+ +-- | Not currently supported | +-- +====================================================================+ +-- | Word | +-- +--------------------------------------------------------------------+ +-- | Float | +-- +--------------------------------------------------------------------+ +-- | Scientific | +-- +--------------------------------------------------------------------+ +-- +-- See . +module Database.Persist.Quasi + ( parse + + -- * 'PersistSettings' + , PersistSettings + , 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 diff --git a/Database/Persist/Quasi/Internal.hs b/Database/Persist/Quasi/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/Internal.hs @@ -0,0 +1,1306 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This @Internal@ module may have breaking changes that will not be reflected +-- in major version bumps. Please use "Database.Persist.Quasi" instead. If you +-- need something in this module, please file an issue on GitHub. +-- +-- @since 2.13.0.0 +module Database.Persist.Quasi.Internal + ( parse + , PersistSettings (..) + , upperCaseSettings + , lowerCaseSettings + , Attribute (..) + , SourceLoc (..) + , sourceLocFromTHLoc + , parseFieldType + , takeColsEx + , CumulativeParseResult + , renderErrors + , parserWarningMessage + + -- * UnboundEntityDef + , UnboundEntityDef (..) + , getUnboundEntityNameHS + , unbindEntityDef + , getUnboundFieldDefs + , UnboundForeignDef (..) + , getSqlNameOr + , UnboundFieldDef (..) + , UnboundCompositeDef (..) + , UnboundIdDef (..) + , unbindFieldDef + , isUnboundFieldNullable + , unboundIdDefToFieldDef + , PrimarySpec (..) + , mkAutoIdField' + , UnboundForeignFieldList (..) + , ForeignFieldReference (..) + , mkKeyConType + , isHaskellUnboundField + , FieldTypeLit (..) + ) where + +import Prelude hiding (lines) + +import Control.Applicative (Alternative ((<|>))) +import Control.Monad +import Data.Char (isDigit, isLower, isSpace, isUpper, toLower) +import Data.Foldable (toList) +import Data.List (find, foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Monoid (mappend) +import Data.Text (Text) +import qualified Data.Text as T +import Database.Persist.EntityDef.Internal +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 (..)) +import qualified Text.Read as R + +data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving (Show) + +parseFieldType :: Text -> Either String FieldType +parseFieldType t0 = + case parseApplyFT t0 of + PSSuccess ft t' + | T.all isSpace t' -> Right ft + PSFail err -> Left $ "PSFail " ++ err + other -> Left $ show other + where + parseApplyFT :: Text -> ParseState FieldType + parseApplyFT t = + case goMany id t of + PSSuccess (ft : fts) t' -> PSSuccess (foldl' FTApp ft fts) t' + PSSuccess [] _ -> PSFail "empty" + PSFail err -> PSFail err + PSDone -> PSDone + + parseEnclosed + :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType + parseEnclosed end ftMod t = + let + (a, b) = T.break (== end) t + in + case parseApplyFT a of + PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of + ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') + (x, y) -> PSFail $ show (b, x, y) + x -> PSFail $ show x + + parse1 :: Text -> ParseState FieldType + parse1 t = fromMaybe (PSFail (show t)) $ do + case T.uncons t of + Nothing -> pure PSDone + Just (x, xs) -> + parseSpace x xs + <|> parseParenEnclosed x xs + <|> parseList x xs + <|> parseNumericLit x xs + <|> parseTextLit x xs + <|> parseTypeCon x xs + + parseSpace :: Char -> Text -> Maybe (ParseState FieldType) + parseSpace c t = do + guard (isSpace c) + pure $ parse1 (T.dropWhile isSpace t) + + parseParenEnclosed c t = do + guard (c == '(') + pure $ parseEnclosed ')' id t + + parseList c t = do + guard (c == '[') + pure $ parseEnclosed ']' FTList t + + parseTextLit :: Char -> Text -> Maybe (ParseState FieldType) + parseTextLit c t = do + guard (c == '"') + let + (a, b) = T.break (== '"') t + lit = FTLit (TextTypeLit a) + pure $ PSSuccess lit (T.drop 1 b) + + parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType) + parseNumericLit c t = do + guard (isDigit c && T.all isDigit t) + let + (a, b) = breakAtNextSpace t + lit <- FTLit . IntTypeLit <$> readMaybe (T.cons c a) + pure $ PSSuccess lit b + + parseTypeCon c t = do + guard (isUpper c || c == '\'') + let + (a, b) = breakAtNextSpace t + pure $ PSSuccess (parseFieldTypePiece c a) b + + goMany :: ([FieldType] -> a) -> Text -> ParseState a + goMany front t = + case parse1 t of + PSSuccess x t' -> goMany (front . (x :)) t' + PSFail err -> PSFail err + PSDone -> PSSuccess (front []) t + +breakAtNextSpace :: Text -> (Text, Text) +breakAtNextSpace = + T.break isSpace + +parseFieldTypePiece :: Char -> Text -> FieldType +parseFieldTypePiece fstChar rest = + case fstChar of + '\'' -> + FTTypePromoted rest + _ -> + let + t = T.cons fstChar rest + in + case T.breakOnEnd "." t of + (_, "") -> FTTypeCon Nothing t + ("", _) -> FTTypeCon Nothing t + (a, b) -> FTTypeCon (Just $ T.init a) b + +sourceLocFromTHLoc :: Loc -> SourceLoc +sourceLocFromTHLoc Loc{loc_filename = filename, loc_start = start} = + SourceLoc + { locFile = T.pack filename + , locStartLine = fst start + , locStartCol = snd start + } + +-- | Parses a quasi-quoted syntax into a list of entity definitions. +parse + :: 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 + +entityNamesFromParsedDef + :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) +entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) + where + entNameHS = + parsedEntityDefEntityName parsedEntDef + + entNameDB = + EntityNameDB $ + getDbName + ps + (unEntityNameHS entNameHS) + (attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef) + +-- | This type represents an @Id@ declaration in the QuasiQuoted syntax. +-- +-- > Id +-- +-- This uses the implied settings, and is equivalent to omitting the @Id@ +-- statement entirely. +-- +-- > Id Text +-- +-- This will set the field type of the ID to be 'Text'. +-- +-- > Id Text sql=foo_id +-- +-- This will set the field type of the Id to be 'Text' and the SQL DB name to be @foo_id@. +-- +-- > Id FooId +-- +-- This results in a shared primary key - the @FooId@ refers to a @Foo@ table. +-- +-- > Id FooId OnDelete Cascade +-- +-- You can set a cascade behavior on an ID column. +-- +-- @since 2.13.0.0 +data UnboundIdDef = UnboundIdDef + { unboundIdEntityName :: EntityNameHS + , unboundIdDBName :: !FieldNameDB + , unboundIdAttrs :: [FieldAttr] + , unboundIdCascade :: FieldCascade + , unboundIdType :: Maybe FieldType + } + deriving (Eq, Ord, Show, Lift) + +-- | An 'EntityDef' produced by the QuasiQuoter. It contains information that +-- the QuasiQuoter is capable of knowing about the entities. It is inherently +-- unfinished, though - there are many other @Unbound@ datatypes that also +-- contain partial information. +-- +-- The 'unboundEntityDef' is not complete or reliable - to know which fields are +-- safe to use, consult the parsing code. +-- +-- This type was completely internal until 2.13.0.0, when it was exposed as part +-- of the "Database.Persist.Quasi.Internal" module. +-- +-- TODO: refactor this so we can expose it for consumers. +-- +-- @since 2.13.0.0 +data UnboundEntityDef + = UnboundEntityDef + { unboundForeignDefs :: [UnboundForeignDef] + -- ^ A list of foreign definitions on the parsed entity. + -- + -- @since 2.13.0.0 + , unboundPrimarySpec :: PrimarySpec + -- ^ The specification for the primary key of the unbound entity. + -- + -- @since 2.13.0.0 + , unboundEntityDef :: EntityDef + -- ^ The incomplete and partial 'EntityDef' that we're defining. We re-use + -- the type here to prevent duplication, but several of the fields are unset + -- and left to defaults. + -- + -- @since 2.13.0.0 + , unboundEntityFields :: [UnboundFieldDef] + -- ^ The list of fields for the entity. We're not capable of knowing + -- information like "is this a reference?" or "what's the underlying type of + -- the field?" yet, so we defer those to the Template Haskell execution. + -- + -- @since 2.13.0.0 + , unboundEntityDefSpan :: Maybe SourceSpan + -- ^ The source code span of this entity in the models file. + -- + -- @since 2.15.0.0 + } + deriving (Eq, Ord, Show, Lift) + +-- | Convert an 'EntityDef' into an 'UnboundEntityDef'. This "forgets" +-- information about the 'EntityDef', but it is all kept present on the +-- 'unboundEntityDef' field if necessary. +-- +-- @since 2.13.0.0 +unbindEntityDef :: EntityDef -> UnboundEntityDef +unbindEntityDef ed = + UnboundEntityDef + { unboundForeignDefs = + map unbindForeignDef (entityForeigns ed) + , unboundPrimarySpec = + case entityId ed of + EntityIdField fd -> + SurrogateKey (unbindIdDef (entityHaskell ed) fd) + EntityIdNaturalKey cd -> + NaturalKey (unbindCompositeDef cd) + , unboundEntityDef = + ed + , unboundEntityFields = + map unbindFieldDef (entityFields ed) + , unboundEntityDefSpan = entitySpan ed + } + +-- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns +-- all fields defined on the entity. +-- +-- @since 2.13.0.0 +getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef] +getUnboundFieldDefs = unboundEntityFields + +-- | This function forgets information about the 'CompositeDef' so that it can +-- be remembered through Template Haskell. +-- +-- @since 2.13.0.0 +unbindCompositeDef :: CompositeDef -> UnboundCompositeDef +unbindCompositeDef cd = + UnboundCompositeDef + { unboundCompositeCols = + fmap fieldHaskell (compositeFields cd) + , unboundCompositeAttrs = + compositeAttrs cd + } + +-- | A representation of a database column, with everything that can be known at +-- parse time. +-- +-- @since 2.13.0.0 +data UnboundFieldDef + = UnboundFieldDef + { unboundFieldNameHS :: FieldNameHS + -- ^ The Haskell name of the field. This is parsed directly from the + -- definition, and is used to generate the Haskell record field and the + -- 'EntityField' definition. + -- + -- @since 2.13.0.0 + , unboundFieldNameDB :: FieldNameDB + -- ^ The database name of the field. By default, this is determined by the + -- 'PersistSettings' record at parse time. You can customize this with + -- a @sql=@ attribute: + -- + -- @ + -- name Text sql=foo_name + -- @ + -- + -- @since 2.13.0.0 + , unboundFieldAttrs :: [FieldAttr] + -- ^ The attributes present on the field. For rules on parsing and utility, + -- see the comments on the datatype. + -- + -- @since 2.13.0.0 + , unboundFieldStrict :: Bool + -- ^ Whether or not the field should be strict in the generated Haskell + -- code. + -- + -- @since 2.13.0.0 + , unboundFieldType :: FieldType + -- ^ The type of the field, as far as is known at parse time. + -- + -- The TemplateHaskell code will reconstruct a 'Type' out of this, but the + -- names will be imported as-is. + -- + -- @since 2.13.0.0 + , unboundFieldCascade :: FieldCascade + -- ^ We parse if there's a 'FieldCascade' on the field. If the field is not + -- a reference, this information is ignored. + -- + -- @ + -- Post + -- user UserId OnDeleteCascade + -- @ + -- + -- @since 2.13.0.0 + , unboundFieldGenerated :: Maybe Text + -- ^ Contains an expression to generate the column. If this is present, then + -- the column will not be written to the database, but generated by the + -- expression every time. + -- + -- @ + -- Item + -- subtotal Int + -- taxRate Rational + -- total Int generated="subtotal * tax_rate" + -- @ + -- + -- @since 2.13.0.0 + , unboundFieldComments :: Maybe Text + -- ^ Any comments present on the field. Documentation comments use + -- a Haskell-like syntax, and must be present before the field in question. + -- + -- @ + -- Post + -- -- | This is the blog post title. + -- title Text + -- -- | You can have multi-line comments. + -- -- | But each line must have the pipe character. + -- author UserId + -- @ + -- + -- @since 2.13.0.0 + } + deriving (Eq, Ord, Show, Lift) + +-- | Forget innformation about a 'FieldDef' so it can beused as an +-- 'UnboundFieldDef'. +-- +-- @since 2.13.0.0 +unbindFieldDef :: FieldDef -> UnboundFieldDef +unbindFieldDef fd = + UnboundFieldDef + { unboundFieldNameHS = + fieldHaskell fd + , unboundFieldNameDB = + fieldDB fd + , unboundFieldAttrs = + fieldAttrs fd + , unboundFieldType = + fieldType fd + , unboundFieldStrict = + fieldStrict fd + , unboundFieldCascade = + fieldCascade fd + , unboundFieldComments = + fieldComments fd + , unboundFieldGenerated = + fieldGenerated fd + } + +isUnboundFieldNullable :: UnboundFieldDef -> IsNullable +isUnboundFieldNullable = + fieldAttrsContainsNullable . unboundFieldAttrs + +-- | The specification for how an entity's primary key should be formed. +-- +-- Persistent requires that every table have a primary key. By default, an +-- implied ID is assigned, based on the 'mpsImplicitIdDef' field on +-- 'MkPersistSettings'. Because we can't access that type at parse-time, we +-- defer that decision until later. +-- +-- @since 2.13.0.0 +data PrimarySpec + = -- | A 'NaturalKey' contains columns that are defined on the datatype + -- itself. This is defined using the @Primary@ keyword and given a non-empty + -- list of columns. + -- + -- @ + -- User + -- name Text + -- email Text + -- + -- Primary name email + -- @ + -- + -- A natural key may also contain only a single column. A natural key with + -- multiple columns is called a 'composite key'. + -- + -- @since 2.13.0.0 + NaturalKey UnboundCompositeDef + | -- | A surrogate key is not part of the domain model for a database table. + -- You can specify a custom surro + -- + -- You can specify a custom surrogate key using the @Id@ syntax. + -- + -- @ + -- User + -- Id Text + -- name Text + -- @ + -- + -- Note that you must provide a @default=@ expression when using this in + -- order to use 'insert' or related functions. The 'insertKey' function can + -- be used instead, as it allows you to specify a key directly. Fixing this + -- issue is tracked in #1247 on GitHub. + -- + -- @since 2.13.0.0 + SurrogateKey UnboundIdDef + | -- | The default key for the entity using the settings in + -- 'MkPersistSettings'. + -- + -- This is implicit - a table without an @Id@ or @Primary@ declaration will + -- have a 'DefaultKey'. + -- + -- @since 2.13.0.0 + DefaultKey FieldNameDB + deriving (Eq, Ord, Show, Lift) + +-- | Construct an entity definition. +mkUnboundEntityDef + :: PersistSettings + -> ParsedEntityDef + -- ^ parsed entity definition + -> UnboundEntityDef +mkUnboundEntityDef ps parsedEntDef = + UnboundEntityDef + { unboundForeignDefs = + entityConstraintDefsForeignsList entityConstraintDefs + , unboundPrimarySpec = + case (idField, primaryComposite) of + (Just{}, Just{}) -> + error "Specified both an ID field and a Primary field" + (Just a, Nothing) -> + if unboundIdType a == Just (mkKeyConType (unboundIdEntityName a)) + then + DefaultKey (FieldNameDB $ psIdName ps) + else + SurrogateKey a + (Nothing, Just a) -> + NaturalKey a + (Nothing, Nothing) -> + DefaultKey (FieldNameDB $ psIdName ps) + , unboundEntityFields = + cols + , unboundEntityDefSpan = parsedEntityDefSpan parsedEntDef + , unboundEntityDef = + EntityDef + { entityHaskell = entNameHS + , entityDB = entNameDB + , -- idField is the user-specified Id + -- otherwise useAutoIdField + -- but, adjust it if the user specified a Primary + entityId = + EntityIdField $ + maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField + , entityAttrs = + attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef + , entityFields = [] + , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs + , entityForeigns = [] + , entityDerives = concat $ mapMaybe takeDerives (textFields ++ textDirectives) + , entityExtra = parsedEntityDefExtras parsedEntDef + , entitySum = parsedEntityDefIsSum parsedEntDef + , entityComments = + case parsedEntityDefComments parsedEntDef of + [] -> Nothing + comments -> Just (T.unlines comments) + , entitySpan = parsedEntityDefSpan parsedEntDef + } + } + where + (entNameHS, entNameDB) = + entityNamesFromParsedDef ps parsedEntDef + + fields = parsedEntityDefFields parsedEntDef + directives = parsedEntityDefDirectives parsedEntDef + + cols :: [UnboundFieldDef] + cols = foldMap (toList . commentedField ps) fields + + textFields :: [[Text]] + textFields = entityFieldContent . fst <$> fields + + textDirectives :: [[Text]] + textDirectives = directiveContent . fst <$> directives + + entityConstraintDefs = + foldMap + (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) + (textFields ++ textDirectives) + + idField = + case entityConstraintDefsIdField entityConstraintDefs of + SetMoreThanOnce -> error "expected only one Id declaration per entity" + SetOnce a -> Just a + NotSet -> Nothing + + primaryComposite = + case entityConstraintDefsPrimaryComposite entityConstraintDefs of + SetMoreThanOnce -> error "expected only one Primary declaration per entity" + SetOnce a -> Just a + NotSet -> Nothing + + commentedField + :: PersistSettings + -> (EntityField, Maybe Text) + -> Maybe UnboundFieldDef + commentedField s (field, mCommentText) = do + unb <- takeColsEx s (entityFieldContent field) + pure $ unb{unboundFieldComments = mCommentText} + + autoIdField :: FieldDef + autoIdField = + mkAutoIdField ps entNameHS idSqlType + + idSqlType :: SqlType + idSqlType = + maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite + +defaultIdName :: PersistSettings -> FieldNameDB +defaultIdName = FieldNameDB . psIdName + +-- | Convert an 'UnboundIdDef' into a 'FieldDef' suitable for use in the +-- 'EntityIdField' constructor. +-- +-- @since 2.13.0.0 +unboundIdDefToFieldDef + :: FieldNameDB + -> EntityNameHS + -> UnboundIdDef + -> FieldDef +unboundIdDefToFieldDef dbField entNameHS uid = + FieldDef + { fieldHaskell = + FieldNameHS "Id" + , fieldDB = + getSqlNameOr dbField (unboundIdAttrs uid) + , fieldType = + fromMaybe (mkKeyConType entNameHS) $ unboundIdType uid + , fieldSqlType = + SqlOther "SqlType unset for Id" + , fieldStrict = + False + , fieldReference = + ForeignRef entNameHS + , fieldAttrs = + unboundIdAttrs uid + , fieldComments = + Nothing + , fieldCascade = unboundIdCascade uid + , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True + } + +-- | Convert an 'EntityNameHS' into 'FieldType' that will get parsed into the ID +-- type for the entity. +-- +-- @ +-- >>> mkKeyConType (EntityNameHS "Hello) +-- FTTypeCon Nothing "HelloId" +-- @ +-- +-- @since 2.13.0.0 +mkKeyConType :: EntityNameHS -> FieldType +mkKeyConType entNameHs = + FTTypeCon Nothing (keyConName entNameHs) + +-- | Assuming that the provided 'FieldDef' is an ID field, this converts it into +-- an 'UnboundIdDef'. +-- +-- @since 2.13.0.0 +unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef +unbindIdDef entityName fd = + UnboundIdDef + { unboundIdEntityName = + entityName + , unboundIdDBName = + fieldDB fd + , unboundIdAttrs = + fieldAttrs fd + , unboundIdCascade = + fieldCascade fd + , unboundIdType = + Just $ fieldType fd + } + +mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef +mkAutoIdField ps = + mkAutoIdField' (FieldNameDB $ psIdName ps) + +mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef +mkAutoIdField' dbName entName idSqlType = + FieldDef + { fieldHaskell = FieldNameHS "Id" + , fieldDB = dbName + , fieldType = FTTypeCon Nothing $ keyConName entName + , fieldSqlType = idSqlType + , fieldReference = NoReference + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True + } + +keyConName :: EntityNameHS -> Text +keyConName entName = unEntityNameHS entName `mappend` "Id" + +isCapitalizedText :: Text -> Bool +isCapitalizedText t = + not (T.null t) && isUpper (T.head t) + +takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef +takeColsEx = + takeCols + (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) + +takeCols + :: (Text -> String -> Maybe UnboundFieldDef) + -> PersistSettings + -> [Text] + -> Maybe UnboundFieldDef +takeCols _ _ ("deriving" : _) = Nothing +takeCols onErr ps (n' : typ : rest') + | not (T.null n) && isLower (T.head n) = + case parseFieldType typ of + Left err -> onErr typ err + Right ft -> + Just + UnboundFieldDef + { unboundFieldNameHS = + FieldNameHS n + , unboundFieldNameDB = + getDbName' ps n fieldAttrs_ + , unboundFieldType = + ft + , unboundFieldAttrs = + fieldAttrs_ + , unboundFieldStrict = + fromMaybe (psStrictFields ps) mstrict + , unboundFieldComments = + Nothing + , unboundFieldCascade = + cascade_ + , unboundFieldGenerated = + generated_ + } + where + fieldAttrs_ = parseFieldAttrs attrs_ + generated_ = parseGenerated attrs_ + (cascade_, attrs_) = parseCascade rest' + (mstrict, n) + | Just x <- T.stripPrefix "!" n' = (Just True, x) + | Just x <- T.stripPrefix "~" n' = (Just False, x) + | otherwise = (Nothing, n') +takeCols _ _ _ = Nothing + +parseGenerated :: [Text] -> Maybe Text +parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing + +getDbName :: PersistSettings -> Text -> [Text] -> Text +getDbName ps n = + fromMaybe (psToDBName ps n) . listToMaybe . mapMaybe (T.stripPrefix "sql=") + +getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB +getDbName' ps n = + getSqlNameOr (FieldNameDB $ psToDBName ps n) + +getSqlNameOr + :: FieldNameDB + -> [FieldAttr] + -> FieldNameDB +getSqlNameOr def = + maybe def FieldNameDB . findAttrSql + where + findAttrSql = + listToMaybe . mapMaybe isAttrSql + isAttrSql attr = + case attr of + FieldAttrSql t -> + Just t + _ -> + Nothing + +data SetOnceAtMost a + = NotSet + | SetOnce a + | SetMoreThanOnce + +instance Semigroup (SetOnceAtMost a) where + a <> b = + case (a, b) of + (_, NotSet) -> a + (NotSet, _) -> b + (SetOnce _, SetOnce _) -> SetMoreThanOnce + _ -> a + +instance Monoid (SetOnceAtMost a) where + mempty = + NotSet + +data EntityConstraintDefs = EntityConstraintDefs + { entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef + , entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef + , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef) + , entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef) + } + +instance Semigroup EntityConstraintDefs where + a <> b = + EntityConstraintDefs + { entityConstraintDefsIdField = + entityConstraintDefsIdField a <> entityConstraintDefsIdField b + , entityConstraintDefsPrimaryComposite = + entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b + , entityConstraintDefsUniques = + entityConstraintDefsUniques a <> entityConstraintDefsUniques b + , entityConstraintDefsForeigns = + entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b + } + +instance Monoid EntityConstraintDefs where + mempty = + EntityConstraintDefs mempty mempty Nothing Nothing + +entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef] +entityConstraintDefsUniquesList = foldMap NEL.toList . entityConstraintDefsUniques + +entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef] +entityConstraintDefsForeignsList = foldMap NEL.toList . entityConstraintDefsForeigns + +takeConstraint + :: PersistSettings + -> EntityNameHS + -> [UnboundFieldDef] + -> NonEmpty Text + -> EntityConstraintDefs +takeConstraint ps entityName defs (n :| rest) = + case n of + "Unique" -> + mempty + { entityConstraintDefsUniques = + pure <$> takeUniq ps (unEntityNameHS entityName) defs rest + } + "Foreign" -> + mempty + { entityConstraintDefsForeigns = + Just $ pure (takeForeign ps entityName rest) + } + "Primary" -> + let + unboundComposite = + takeComposite (unboundFieldNameHS <$> defs) rest + in + mempty + { entityConstraintDefsPrimaryComposite = + SetOnce unboundComposite + , entityConstraintDefsUniques = + Just $ pure $ compositeToUniqueDef entityName defs unboundComposite + } + "Id" -> + mempty + { entityConstraintDefsIdField = + SetOnce (takeId ps entityName rest) + } + _ + | isCapitalizedText n -> + mempty + { entityConstraintDefsUniques = + pure <$> takeUniq ps "" defs (n : rest) + } + _ -> + mempty + +-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. +-- need to re-work takeCols function +takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef +takeId ps entityName texts = + UnboundIdDef + { unboundIdDBName = + FieldNameDB $ psIdName ps + , unboundIdEntityName = + entityName + , unboundIdCascade = + cascade_ + , unboundIdAttrs = + parseFieldAttrs attrs_ + , unboundIdType = + typ + } + where + typ = + case texts of + [] -> + Nothing + (t : _) -> + case parseFieldType t of + Left _ -> + Nothing + Right ft -> + Just ft + (cascade_, attrs_) = parseCascade texts + +-- | A definition for a composite primary key. +-- +-- @since.2.13.0.0 +data UnboundCompositeDef = UnboundCompositeDef + { unboundCompositeCols :: NonEmpty FieldNameHS + -- ^ The field names for the primary key. + -- + -- @since 2.13.0.0 + , unboundCompositeAttrs :: [Attr] + -- ^ A list of attributes defined on the primary key. This is anything that + -- occurs after a @!@ character. + -- + -- @since 2.13.0.0 + } + deriving (Eq, Ord, Show, Lift) + +compositeToUniqueDef + :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef +compositeToUniqueDef entityName fields UnboundCompositeDef{..} = + UniqueDef + { uniqueHaskell = + ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey") + , uniqueDBName = + ConstraintNameDB "primary_key" + , uniqueFields = + fmap (\hsName -> (hsName, getDbNameFor hsName)) unboundCompositeCols + , uniqueAttrs = + unboundCompositeAttrs + } + where + getDbNameFor hsName = + case mapMaybe (matchHsName hsName) fields of + [] -> + error "Unable to find `hsName` in fields" + (a : _) -> + a + matchHsName hsName UnboundFieldDef{..} = do + guard $ unboundFieldNameHS == hsName + pure unboundFieldNameDB + +takeComposite + :: [FieldNameHS] + -> [Text] + -> UnboundCompositeDef +takeComposite fields pkcols = + UnboundCompositeDef + { unboundCompositeCols = + fmap (getDef fields) neCols + , unboundCompositeAttrs = + attrs + } + where + neCols = + case NEL.nonEmpty cols of + Nothing -> + error "No fields provided for primary key" + Just xs -> + xs + (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols + getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t + getDef (d : ds) t + | d == FieldNameHS t = + -- TODO: check for nullability in later step + -- if nullable (fieldAttrs d) /= NotNullable + -- then error $ "primary key column cannot be nullable: " ++ show t ++ show fields + d + | otherwise = + getDef ds t + +-- Unique UppercaseConstraintName list of lowercasefields terminated +-- by ! or sql= such that a unique constraint can look like: +-- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` +-- Here using sql= sets the name of the constraint. +takeUniq + :: PersistSettings + -> Text + -> [UnboundFieldDef] + -> [Text] + -> Maybe UniqueDef +takeUniq ps tableName defs (n : rest) + | isCapitalizedText n = do + fields <- mfields + pure + UniqueDef + { uniqueHaskell = + ConstraintNameHS n + , uniqueDBName = + dbName + , uniqueFields = + fmap (\a -> (FieldNameHS a, getDBName defs a)) fields + , uniqueAttrs = + attrs + } + where + isAttr a = + "!" `T.isPrefixOf` a + isSqlName a = + "sql=" `T.isPrefixOf` a + isNonField a = + isAttr a || isSqlName a + (fieldsList, nonFields) = + break isNonField rest + mfields = + NEL.nonEmpty fieldsList + + attrs = filter isAttr nonFields + + usualDbName = + ConstraintNameDB $ psToDBName ps (tableName `T.append` n) + sqlName :: Maybe ConstraintNameDB + sqlName = + case find isSqlName nonFields of + Nothing -> + Nothing + (Just t) -> + case drop 1 $ T.splitOn "=" t of + (x : _) -> Just (ConstraintNameDB x) + _ -> Nothing + dbName = fromMaybe usualDbName sqlName + + getDBName [] t = error $ T.unpack (unknownUniqueColumnError t defs n) + getDBName (d : ds) t + | unboundFieldNameHS d == FieldNameHS t = + unboundFieldNameDB d + | otherwise = + getDBName ds t +takeUniq _ tableName _ xs = + error $ + "invalid unique constraint on table[" + ++ show tableName + ++ "] expecting an uppercase constraint name xs=" + ++ show xs + +unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text +unknownUniqueColumnError t defs n = + "Unknown column in \"" + <> n + <> "\" constraint: \"" + <> t + <> "\"" + <> " possible fields: " + <> T.pack (show (toFieldName <$> defs)) + where + toFieldName :: UnboundFieldDef -> Text + toFieldName fd = + unFieldNameHS (unboundFieldNameHS fd) + +-- | Define an explicit foreign key reference. +-- +-- @ +-- User +-- name Text +-- email Text +-- +-- Primary name email +-- +-- Dog +-- ownerName Text +-- ownerEmail Text +-- +-- Foreign User fk_dog_user ownerName ownerEmail +-- @ +-- +-- @since 2.13.0.0 +data UnboundForeignDef + = UnboundForeignDef + { unboundForeignFields :: UnboundForeignFieldList + -- ^ Fields in the source entity. + -- + -- @since 2.13.0.0 + , unboundForeignDef :: ForeignDef + -- ^ The 'ForeignDef' which needs information filled in. + -- + -- This value is unreliable. See the parsing code to see what data is filled + -- in here. + -- + -- @since 2.13.0.0 + } + deriving (Eq, Ord, Show, Lift) + +-- | A list of fields present on the foreign reference. +data UnboundForeignFieldList + = -- | If no @References@ keyword is supplied, then it is assumed that you are + -- referring to the @Primary@ key or @Id@ of the target entity. + -- + -- @since 2.13.0.0 + FieldListImpliedId (NonEmpty FieldNameHS) + | -- | You can specify the exact columns you're referring to here, if they + -- aren't part of a primary key. Most databases expect a unique index on the + -- columns you refer to, but Persistent doesnt' check that. + -- + -- @ + -- User + -- Id UUID default="uuid_generate_v1mc()" + -- name Text + -- + -- UniqueName name + -- + -- Dog + -- ownerName Text + -- + -- Foreign User fk_dog_user ownerName References name + -- @ + -- + -- @since 2.13.0.0 + FieldListHasReferences (NonEmpty ForeignFieldReference) + deriving (Eq, Ord, Show, Lift) + +-- | A pairing of the 'FieldNameHS' for the source table to the 'FieldNameHS' +-- for the target table. +-- +-- @since 2.13.0.0 +data ForeignFieldReference + = ForeignFieldReference + { ffrSourceField :: FieldNameHS + -- ^ The column on the source table. + -- + -- @since 2.13.0.0 + , ffrTargetField :: FieldNameHS + -- ^ The column on the target table. + -- + -- @since 2.13.0.0 + } + deriving (Eq, Ord, Show, Lift) + +unbindForeignDef :: ForeignDef -> UnboundForeignDef +unbindForeignDef fd = + UnboundForeignDef + { unboundForeignFields = + FieldListHasReferences $ NEL.fromList $ fmap mk (foreignFields fd) + , unboundForeignDef = + fd + } + where + mk ((fH, _), (pH, _)) = + ForeignFieldReference + { ffrSourceField = fH + , ffrTargetField = pH + } + +mkUnboundForeignFieldList + :: [Text] + -> [Text] + -> Either String UnboundForeignFieldList +mkUnboundForeignFieldList (fmap FieldNameHS -> source) (fmap FieldNameHS -> target) = + case NEL.nonEmpty source of + Nothing -> + Left "No fields on foreign reference." + Just sources -> + case NEL.nonEmpty target of + Nothing -> + Right $ FieldListImpliedId sources + Just targets -> + if length targets /= length sources + then + Left "Target and source length differe on foreign reference." + else + Right $ + FieldListHasReferences $ + NEL.zipWith ForeignFieldReference sources targets + +takeForeign + :: PersistSettings + -> EntityNameHS + -> [Text] + -> UnboundForeignDef +takeForeign ps entityName = takeRefTable + where + errorPrefix :: String + errorPrefix = + "invalid foreign key constraint on table[" + ++ show (unEntityNameHS entityName) + ++ "] " + + takeRefTable :: [Text] -> UnboundForeignDef + takeRefTable [] = + error $ errorPrefix ++ " expecting foreign table name" + takeRefTable (refTableName : restLine) = + go restLine Nothing Nothing + where + go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef + go (constraintNameText : rest) onDelete onUpdate + | not (T.null constraintNameText) && isLower (T.head constraintNameText) = + UnboundForeignDef + { unboundForeignFields = + either error id $ mkUnboundForeignFieldList foreignFields parentFields + , unboundForeignDef = + ForeignDef + { foreignRefTableHaskell = + EntityNameHS refTableName + , foreignRefTableDBName = + EntityNameDB $ psToDBName ps refTableName + , foreignConstraintNameHaskell = + constraintName + , foreignConstraintNameDBName = + toFKConstraintNameDB ps entityName constraintName + , foreignFieldCascade = + FieldCascade + { fcOnDelete = onDelete + , fcOnUpdate = onUpdate + } + , foreignAttrs = + attrs + , foreignFields = + [] + , foreignNullable = + False + , foreignToPrimary = + null parentFields + } + } + where + constraintName = + ConstraintNameHS constraintNameText + + (fields, attrs) = + break ("!" `T.isPrefixOf`) rest + (foreignFields, parentFields) = + case break (== "References") fields of + (ffs, []) -> + (ffs, []) + (ffs, _ : pfs) -> + case (length ffs, length pfs) of + (flen, plen) + | flen == plen -> + (ffs, pfs) + (flen, plen) -> + error $ + errorPrefix + ++ concat + [ "Found " + , show flen + , " foreign fields but " + , show plen + , " parent fields" + ] + go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = + case onDelete' of + Nothing -> + go rest (Just cascadingAction) onUpdate + Just _ -> + error $ errorPrefix ++ "found more than one OnDelete actions" + go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = + case onUpdate' of + Nothing -> + go rest onDelete (Just cascadingAction) + Just _ -> + error $ errorPrefix ++ "found more than one OnUpdate actions" + go xs _ _ = + error $ + errorPrefix + ++ "expecting a lower case constraint name or a cascading action xs=" + ++ show xs + +toFKConstraintNameDB + :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB +toFKConstraintNameDB ps entityName constraintName = + ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName) +data CascadePrefix = CascadeUpdate | CascadeDelete + +parseCascade :: [Text] -> (FieldCascade, [Text]) +parseCascade allTokens = + go [] Nothing Nothing allTokens + where + go acc mupd mdel tokens_ = + case tokens_ of + [] -> + ( FieldCascade + { fcOnDelete = mdel + , fcOnUpdate = mupd + } + , acc + ) + this : rest -> + case parseCascadeAction CascadeUpdate this of + Just cascUpd -> + case mupd of + Nothing -> + go acc (Just cascUpd) mdel rest + Just _ -> + nope "found more than one OnUpdate action" + Nothing -> + case parseCascadeAction CascadeDelete this of + Just cascDel -> + case mdel of + Nothing -> + go acc mupd (Just cascDel) rest + Just _ -> + nope "found more than one OnDelete action" + Nothing -> + go (this : acc) mupd mdel rest + nope msg = + error $ msg <> ", tokens: " <> show allTokens + +parseCascadeAction + :: CascadePrefix + -> Text + -> Maybe CascadeAction +parseCascadeAction prfx text = do + cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text + readMaybe cascadeStr + where + toPrefix cp = + case cp of + CascadeUpdate -> "Update" + CascadeDelete -> "Delete" + +takeDerives :: [Text] -> Maybe [Text] +takeDerives ("deriving" : rest) = Just rest +takeDerives _ = Nothing + +-- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or +-- 'SafeToRemove' flag from the QuasiQuoter. +-- +-- @since 2.13.0.0 +isHaskellUnboundField :: UnboundFieldDef -> Bool +isHaskellUnboundField fd = + FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd + && FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd + +-- | Return the 'EntityNameHS' for an 'UnboundEntityDef'. +-- +-- @since 2.13.0.0 +getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS +getUnboundEntityNameHS = entityHaskell . unboundEntityDef + +readMaybe :: (Read a) => Text -> Maybe a +readMaybe = R.readMaybe . T.unpack diff --git a/Database/Persist/Quasi/Internal/ModelParser.hs b/Database/Persist/Quasi/Internal/ModelParser.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/Internal/ModelParser.hs @@ -0,0 +1,983 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Database.Persist.Quasi.Internal.ModelParser + ( SourceLoc (..) + , Attribute (..) + , attribute + , attributeContent + , Directive (..) + , directiveContent + , EntityField (..) + , entityField + , entityFieldContent + , FieldName (..) + , fieldName + , ParsedEntityDef (..) + , parseSource + , memberEntityFields + , ParserWarning + , parserWarningMessage + , ParseResult + , CumulativeParseResult + , toCumulativeParseResult + , renderErrors + , runConfiguredParser + , ParserErrorLevel (..) + , initialExtraState + ) where + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus, void) +import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) +import Control.Monad.State +import Control.Monad.Writer +import Data.Char (isSpace) +import Data.Either (partitionEithers) +import Data.Foldable (fold) +import Data.Functor.Identity +import Data.List (intercalate) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Void +import Database.Persist.Quasi.Internal.TypeParser +import Database.Persist.Quasi.PersistSettings.Internal +import Database.Persist.Types +import Database.Persist.Types.SourceSpan +import Language.Haskell.TH.Syntax (Lift) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import qualified Text.Megaparsec.Stream as TMS + +-- We'll augment the parser with extra state to accumulate comments seen during parsing. +-- Comments are lexed as whitespace, but will be used to generate documentation later. +data ExtraState = ExtraState + { esPositionedCommentTokens :: [(SourcePos, CommentToken)] + , esLastDocumentablePosition :: Maybe SourcePos + } + +-- @since 2.16.0.0 +initialExtraState :: ExtraState +initialExtraState = + ExtraState + { esPositionedCommentTokens = [] + , esLastDocumentablePosition = Nothing + } + +newtype Parser a = Parser + { unParser + :: ReaderT + PersistSettings + ( StateT + ExtraState + ( ParsecT + Void + String + ( Writer + (Set ParserWarning) + ) + ) + ) + a + } + deriving newtype + ( Functor + , Applicative + , Monad + , Alternative + , MonadPlus + , MonadState ExtraState + , MonadReader PersistSettings + , MonadParsec Void String + , MonadFail + ) + +type EntityParseError = ParseErrorBundle String Void + +-- | Result of parsing a single source text. +-- +-- @since 2.16.0.0 +type ParseResult a = + (Set ParserWarning, Either (ParseErrorBundle String Void) a) + +type InternalParseResult a = ParseResult (a, ExtraState) + +-- | Cumulative result of parsing multiple source texts. +-- +-- @since 2.16.0.0 +type CumulativeParseResult a = (Set ParserWarning, Either [EntityParseError] a) + +toCumulativeParseResult + :: (Monoid a) => [ParseResult a] -> CumulativeParseResult a +toCumulativeParseResult prs = do + let + (warnings, eithers) = sequence prs + case partitionEithers eithers of + ([], results) -> (warnings, Right $ fold results) + (errs, _) -> (warnings, Left errs) + +-- | Run a parser using provided PersistSettings and ExtraState +-- @since 2.16.0.0 +runConfiguredParser + :: PersistSettings + -> ExtraState + -> Parser a + -> String + -> String + -> InternalParseResult a +runConfiguredParser ps acc parser fp s = (warnings, either) + where + sm = runReaderT (unParser parser) ps + pm = runStateT sm acc + wm = runParserT' pm initialInternalState + ((_is, either), warnings) = runWriter wm + + initialSourcePos = + SourcePos + { sourceName = fp + , sourceLine = pos1 + , sourceColumn = pos1 + } + initialPosState = + PosState + { pstateInput = s + , pstateOffset = 0 + , pstateSourcePos = initialSourcePos + , -- for legacy compatibility, we treat each tab as a single unit of whitespace + pstateTabWidth = pos1 + , pstateLinePrefix = "" + } + initialInternalState = + State + { stateInput = s + , stateOffset = 0 + , statePosState = initialPosState + , stateParseErrors = [] + } + +reportWarnings :: Set ParserWarning -> Parser () +#if MIN_VERSION_megaparsec(9,5,0) +reportWarnings = Parser . tell +#else +reportWarnings _pw = pure () +#endif + +-- | Renders a list of EntityParseErrors as a String using `errorBundlePretty`, +-- separated by line breaks. +-- @since 2.16.0.0 +renderErrors :: [EntityParseError] -> String +renderErrors errs = intercalate "\n" $ fmap errorBundlePretty errs + +-- | Attempts to parse with a provided parser. If it fails with an error matching +-- the provided predicate, it registers a warning with the provided message and falls +-- back to the second provided parser. +tryOrWarn + :: String + -> (ParseError String Void -> Bool) + -> Parser a + -> Parser a + -> Parser a +tryOrWarn msg p l r = do + parserState <- getParserState + withRecovery (warnAndRetry $ statePosState parserState) l + where + warnAndRetry posState err = do + if p err + then do + let + (pairs, _) = attachSourcePos errorOffset [err] posState + reportWarnings . Set.fromList $ + map + ( \(e, _pos) -> + ParserWarning + { parserWarningExtraMessage = msg <> "\n" + , parserWarningUnderlyingError = e + , parserWarningPosState = posState + } + ) + pairs + r + 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 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 + :: (ParseError String Void -> Bool) + -> Parser a + -> Parser a + -> Parser a +tryOrRegisterError p l r = do + parserState <- getParserState + withRecovery (delayedError $ statePosState parserState) l + where + delayedError posState err = do + if p err + then do + let + (pairs, _) = attachSourcePos errorOffset [err] posState + registerParseError err + r + else parseError err + +tryOrReport + :: Maybe ParserErrorLevel + -> String + -> (ParseError String Void -> Bool) + -> Parser a + -> Parser a + -> Parser a +tryOrReport level msg p l r = case level of + Just LevelError -> tryOrRegisterError p l r + Just LevelWarning -> tryOrWarn msg p l r + Nothing -> r + +-- | Source location: file and line/col information. This is half of a 'SourceSpan'. +-- +-- @since 2.16.0.0 +data SourceLoc = SourceLoc + { locFile :: Text + , locStartLine :: Int + , locStartCol :: Int + } + deriving (Show, Lift) + +-- | An attribute of an entity field definition or a directive. +-- +-- @since 2.17.1.0 +data Attribute + = Assignment Text Text + | Parenthetical 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 an attribute into a Text representation for second-stage parsing or +-- presentation to the user +-- +-- @since 2.16.0.0 +attributeContent :: Attribute -> Text +attributeContent = \case + Assignment l r -> mconcat [l, "=", r] + Parenthetical s -> s + PText 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 + content <- + string "-- |" *> validHSpace *> takeWhileP (Just "character") (/= '\n') + pure (pos, DocComment (Text.pack content)) + +comment :: Parser (SourcePos, CommentToken) +comment = do + pos <- getSourcePos + content <- + (string "--" <|> string "#") + *> validHSpace + *> takeWhileP (Just "character") (/= '\n') + pure (pos, Comment (Text.pack content)) + +skipComment :: Parser () +skipComment = do + content <- docComment <|> comment + void $ appendCommentToState content + +isValidHSpace :: Bool -> Char -> Bool +isValidHSpace allowTabs c = + if allowTabs + then isSpace c && c /= '\n' + else isSpace c && c /= '\n' && c /= '\t' + +isValidSpace :: Bool -> Char -> Bool +isValidSpace allowTabs c = + if allowTabs + then isSpace c + else isSpace c && c /= '\t' + +validSpaceParser + :: (Maybe String -> (TMS.Token String -> Bool) -> Parser (Tokens String)) + -> (Bool -> Char -> Bool) + -> Parser () +validSpaceParser taker validator = do + tabErrorLevel <- asks psTabErrorLevel + void $ + tryOrReport + tabErrorLevel + "use spaces instead of tabs" + isUnexpectedTabError + (taker (Just "valid whitespace") (validator False)) + (taker (Just "valid whitespace") (validator True)) + +isUnexpectedTabError :: ParseError String Void -> Bool +isUnexpectedTabError (TrivialError _ ue l) = + ue == Just (Tokens ('\t' :| "")) + && l == Set.singleton (Label ('v' :| "alid whitespace")) +isUnexpectedTabError _ = False + +someValidHSpace :: Parser () +someValidHSpace = validSpaceParser takeWhile1P isValidHSpace + +someValidSpace :: Parser () +someValidSpace = validSpaceParser takeWhile1P isValidSpace + +validHSpace :: Parser () +validHSpace = validSpaceParser takeWhileP isValidHSpace + +spaceConsumer :: Parser () +spaceConsumer = + L.space + someValidHSpace + skipComment + empty + +spaceConsumerN :: Parser () +spaceConsumerN = + L.space + someValidSpace + 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 + [ alphaNumChar + , char '.' + , char '[' + , char ']' + , char '_' + , char '\'' + , char '"' + , char '!' + , char '~' + , char '-' + , char ':' + , char ',' + , do + backslash <- char '\\' + nextChar <- lookAhead anySingle + if nextChar == '(' || nextChar == ')' + then single nextChar + else pure backslash + ] + +nonLineSpaceChar :: Parser Char +nonLineSpaceChar = choice [char ' ', char '\t'] + +-- This is a replacement for `Text.Megaparsec.Char.Lexer.charLiteral`; +-- it does nearly the same thing but additionally supports escaped parentheses. +charLiteral :: Parser Char +charLiteral = label "literal character" $ do + char1 <- anySingle + case char1 of + '\\' -> do + char2 <- anySingle + case char2 of + '(' -> pure '(' + ')' -> pure ')' + '\\' -> pure '\\' + '\"' -> pure '\"' + '\'' -> pure '\'' + _ -> unexpected (Tokens $ char2 :| []) + _ -> pure char1 + +assignment :: Parser Attribute +assignment = label "assignment expression" $ do + L.lexeme spaceConsumer $ do + lhs <- some contentChar + _ <- char '=' + rhs <- + choice + [ quotation + , sqlLiteral + , parentheticalInner + , try sqlFunctionApplication + , some $ contentChar <|> char '(' <|> char ')' + ] + 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 = + some $ + choice + [ alphaNumChar + , char '_' + ] + +sqlLiteral :: Parser String +sqlLiteral = label "SQL literal" $ do + quote <- L.lexeme spaceConsumer $ char '\'' *> manyTill charLiteral (char '\'') + st <- optional $ do + colons <- string "::" + tn <- sqlTypeName + pure $ colons <> tn + pure $ + mconcat + [ "'" + , quote + , "'" + , fromMaybe "" st + ] + +quotation :: Parser String +quotation = char '"' *> manyTill charLiteral (char '"') + +parenthetical :: Parser Attribute +parenthetical = label "parenthetical" $ do + str <- L.lexeme spaceConsumer parenthetical' + pure . Parenthetical . Text.pack . init . drop 1 $ str + +parenthetical' :: Parser String +parenthetical' = do + str <- between (char '(') (char ')') q + pure $ "(" ++ str ++ ")" + where + q = mconcat <$> some (c <|> parenthetical') + c = (: []) <$> choice [contentChar, nonLineSpaceChar, char '"'] + +blockKey :: Parser BlockKey +blockKey = label "block key" $ do + fl <- upperChar + rl <- many alphaNumChar + pure . BlockKey . Text.pack $ fl : rl + +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 + +data ParsedEntityDef = ParsedEntityDef + { parsedEntityDefComments :: [Text] + , parsedEntityDefEntityName :: EntityNameHS + , parsedEntityDefIsSum :: Bool + , parsedEntityDefEntityAttributes :: [Attribute] + , parsedEntityDefFields :: [(EntityField, Maybe Text)] + , parsedEntityDefDirectives :: [(Directive, Maybe Text)] + , parsedEntityDefExtras :: M.Map Text [ExtraLine] + , parsedEntityDefSpan :: Maybe SourceSpan + } + deriving (Show) + +data DocCommentBlock = DocCommentBlock + { docCommentBlockLines :: [Text] + , docCommentBlockPos :: SourcePos + } + deriving (Show) + +data EntityHeader = EntityHeader + { entityHeaderSum :: Bool + , entityHeaderTableName :: Text + , entityHeaderRemainingAttributes :: [Attribute] + , entityHeaderPos :: SourcePos + } + deriving (Show) + +data EntityBlock = EntityBlock + { entityBlockDocCommentBlock :: Maybe DocCommentBlock + , entityBlockEntityHeader :: EntityHeader + , entityBlockMembers :: [Member] + } + deriving (Show) + +entityBlockFirstPos :: EntityBlock -> SourcePos +entityBlockFirstPos = entityHeaderPos . entityBlockEntityHeader + +entityBlockLastPos :: EntityBlock -> SourcePos +entityBlockLastPos eb = case entityBlockMembers eb of + [] -> entityBlockFirstPos eb + members -> maximum $ fmap memberEndPos members + +entityBlockEntityFields :: EntityBlock -> [EntityField] +entityBlockEntityFields = foldMap f <$> entityBlockMembers + where + f m = case m of + MemberExtraBlock _ -> [] + MemberEntityField ba -> [ba] + MemberDirective _ -> [] + +entityBlockExtraBlocks :: EntityBlock -> [ExtraBlock] +entityBlockExtraBlocks = foldMap f <$> entityBlockMembers + where + f m = case m of + MemberExtraBlock eb -> [eb] + 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 + , extraBlockHeaderRemainingAttributes :: [Attribute] + , extraBlockHeaderPos :: SourcePos + } + deriving (Show) + +data ExtraBlock = ExtraBlock + { extraBlockDocCommentBlock :: Maybe DocCommentBlock + , extraBlockExtraBlockHeader :: ExtraBlockHeader + , extraBlockLines :: NonEmpty ExtraBlockLine + } + deriving (Show) + +data FieldStrictness = Strict | Lazy + deriving (Show) + +newtype FieldName = FieldName Text + deriving (Show, Eq) + +newtype DirectiveName = DirectiveName Text + deriving (Show, Eq) + +data EntityField = EntityField + { entityFieldDocCommentBlock :: Maybe DocCommentBlock + , entityFieldStrictness :: Maybe FieldStrictness + , entityFieldName :: FieldName + , entityFieldType :: TypeExpr + , entityFieldAttributes :: [Attribute] + , entityFieldPos :: SourcePos + } + deriving (Show) + +data 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 (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 EntityFields +-- +-- @since 2.16.0.0 +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 + , 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 attribute) + _ <- setLastDocumentablePosition + pure + EntityHeader + { entityHeaderSum = isJust plus + , entityHeaderTableName = blockKeyContent en + , entityHeaderRemainingAttributes = rest + , entityHeaderPos = pos + } + +appendCommentToState :: (SourcePos, CommentToken) -> Parser () +appendCommentToState ptok = + modify $ \es -> + let + comments = esPositionedCommentTokens es + in + es{esPositionedCommentTokens = ptok : comments} + +setLastDocumentablePosition :: Parser () +setLastDocumentablePosition = do + pos <- getSourcePos + modify $ \es -> es{esLastDocumentablePosition = Just pos} + +getDcb :: Parser (Maybe DocCommentBlock) +getDcb = do + es <- get + let + comments = reverse $ esPositionedCommentTokens es + _ <- put es{esPositionedCommentTokens = []} + let + candidates = dropWhile (\(_sp, ct) -> not (isDocComment ct)) comments + filteredCandidates = dropWhile (commentIsIncorrectlyPositioned es) candidates + pure $ docCommentBlockFromPositionedAttributes filteredCandidates + where + commentIsIncorrectlyPositioned + :: ExtraState -> (SourcePos, CommentToken) -> Bool + commentIsIncorrectlyPositioned es ptok = case esLastDocumentablePosition es of + Nothing -> False + Just lastDocumentablePos -> (sourceLine . fst) ptok <= sourceLine lastDocumentablePos + +extraBlock :: Parser Member +extraBlock = L.indentBlock spaceConsumerN innerParser + where + mkExtraBlockMember dcb (header, extraBlockLines) = + MemberExtraBlock + ExtraBlock + { extraBlockExtraBlockHeader = header + , extraBlockLines = ensureNonEmpty extraBlockLines + , extraBlockDocCommentBlock = dcb + } + ensureNonEmpty lines = case NEL.nonEmpty lines of + Just nel -> nel + Nothing -> error "unreachable" -- lines is known to be non-empty + innerParser = do + dcb <- getDcb + header <- extraBlockHeader + pure $ + 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 attribute) + _ <- setLastDocumentablePosition + pure $ + ExtraBlockHeader + { extraBlockHeaderKey = blockKeyContent tn + , extraBlockHeaderRemainingAttributes = rest + , extraBlockHeaderPos = pos + } + +extraBlockLine :: Parser ExtraBlockLine +extraBlockLine = do + dcb <- getDcb + pos <- getSourcePos + tokens <- some $ L.lexeme spaceConsumer (some contentChar) + _ <- setLastDocumentablePosition + pure $ + ExtraBlockLine + { extraBlockLineDocCommentBlock = dcb + , extraBlockLineTokens = tokens + , extraBlockLinePos = pos + } + +entityField :: Parser Member +entityField = do + dcb <- getDcb + pos <- getSourcePos + ss <- optional fieldStrictness + fn <- L.lexeme spaceConsumer fieldName + ft <- L.lexeme spaceConsumer typeExpr -- Note that `typeExpr` consumes outer parentheses. + fa <- L.lexeme spaceConsumer (many attribute) + _ <- setLastDocumentablePosition + lookAhead (void newline <|> eof) + pure $ + MemberEntityField + EntityField + { entityFieldDocCommentBlock = dcb + , entityFieldStrictness = ss + , entityFieldName = fn + , entityFieldType = ft + , entityFieldAttributes = fa + , entityFieldPos = pos + } + +directiveNameP :: Parser DirectiveName +directiveNameP = + label "directive name" $ + DirectiveName . Text.pack + <$> choice + [ string "deriving" + , directiveName' + ] + where + directiveName' = do + fl <- upperChar + rl <- many alphaNumChar + pure (fl : rl) + +directive :: Parser Member +directive = do + dcb <- getDcb + pos <- getSourcePos + 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 = + choice + [ try extraBlock + , directive + , entityField + ] + +entityBlock :: Parser EntityBlock +entityBlock = do + L.indentBlock spaceConsumerN innerParser + where + mkEntityBlock dcb (header, members) = + EntityBlock + { entityBlockEntityHeader = header + , entityBlockMembers = members + , entityBlockDocCommentBlock = dcb + } + innerParser = do + dcb <- getDcb + header <- entityHeader + pure $ L.IndentMany Nothing (return . mkEntityBlock dcb . (header,)) member + +entitiesFromDocument :: Parser [EntityBlock] +entitiesFromDocument = many entityBlock + +docCommentBlockText :: DocCommentBlock -> Text +docCommentBlockText dcb = Text.unlines $ docCommentBlockLines dcb + +isDocComment :: CommentToken -> Bool +isDocComment tok = case tok of + DocComment _ -> True + _ -> False + +docCommentBlockFromPositionedAttributes + :: [(SourcePos, CommentToken)] -> Maybe DocCommentBlock +docCommentBlockFromPositionedAttributes ptoks = + case NEL.nonEmpty ptoks of + Nothing -> Nothing + Just nel -> + Just $ + DocCommentBlock + { docCommentBlockLines = NEL.toList $ fmap (commentContent . snd) nel + , docCommentBlockPos = fst $ NEL.head nel + } + +parseEntities + :: PersistSettings + -> Text + -> String + -> ParseResult [EntityBlock] +parseEntities ps fp s = do + let + (warnings, res) = + runConfiguredParser ps initialExtraState entitiesFromDocument (Text.unpack fp) s + case res of + Left peb -> + (warnings, Left peb) + Right (entities, _comments) -> + (warnings, pure entities) + +toParsedEntityDef :: Maybe SourceLoc -> EntityBlock -> ParsedEntityDef +toParsedEntityDef mSourceLoc eb = + ParsedEntityDef + { parsedEntityDefComments = comments + , parsedEntityDefEntityName = entityNameHS + , parsedEntityDefIsSum = isSum + , parsedEntityDefEntityAttributes = entityAttributes + , parsedEntityDefFields = parsedFields + , parsedEntityDefDirectives = parsedDirectives + , parsedEntityDefExtras = extras + , parsedEntityDefSpan = mSpan + } + where + comments = + maybe + [] + docCommentBlockLines + (entityBlockDocCommentBlock eb) + entityAttributes = entityHeaderRemainingAttributes . entityBlockEntityHeader $ eb + isSum = entityHeaderSum . entityBlockEntityHeader $ eb + entityNameHS = EntityNameHS . entityHeaderTableName . entityBlockEntityHeader $ 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 + relativeStartLine = maybe 0 locStartLine mSourceLoc + relativeStartCol = maybe 0 locStartCol mSourceLoc + mSpan = + Just + SourceSpan + { spanFile = filepath + , spanStartLine = + relativeStartLine + (unPos . sourceLine $ entityBlockFirstPos eb) + , spanEndLine = relativeStartLine + (unPos . sourceLine $ entityBlockLastPos eb) + , spanStartCol = + relativeStartCol + (unPos . sourceColumn $ entityBlockFirstPos eb) + , spanEndCol = unPos . sourceColumn $ entityBlockLastPos eb + } + +parseSource + :: PersistSettings + -> Maybe SourceLoc + -> Text + -> ParseResult [ParsedEntityDef] +parseSource ps mSourceLoc source = + fmap (fmap (toParsedEntityDef mSourceLoc)) + <$> parseEntities ps filepath (Text.unpack source) + where + filepath = maybe "" locFile mSourceLoc diff --git a/Database/Persist/Quasi/Internal/TypeParser.hs b/Database/Persist/Quasi/Internal/TypeParser.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/Internal/TypeParser.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.Persist.Quasi.Internal.TypeParser + ( TypeExpr (..) + , TypeConstructor (..) + , typeExpr + , innerTypeExpr + , typeExprContent + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +-- | A parsed type expression. +-- +-- @since 2.17.1.0 +data TypeExpr + = TypeApplication TypeExpr [TypeExpr] + | TypeConstructorExpr TypeConstructor + | TypeLitString String + | TypeLitInt String + | TypeLitPromotedConstructor TypeConstructor + deriving (Show, Eq) + +-- | A parsed type constructor. +-- +-- @since 2.17.1.0 +data TypeConstructor + = ListConstructor + | TypeConstructor String + deriving (Show, Eq) + +-- | Parses a Persistent-style type expression. +-- Persistent's type expressions are largely similar to Haskell's, but with a few differences: +-- +-- 1. Syntactic sugar is not currently supported for constructing types other than List. +-- 2. Only certain typelevel literals are supported: Strings, Ints, and promoted type constructors. +-- 3. Because they must be parsed as part of an entity field definition, top-level applications +-- of non-nullary type constructors (except for the sugary List constructor) must +-- be parenthesized. +-- +-- VALID: Int +-- VALID: [Maybe Int] +-- VALID: (Maybe Int) +-- INVALID: Maybe Int +-- +-- @since 2.17.1.0 +typeExpr :: ((MonadParsec e String) m) => m TypeExpr +typeExpr = typeExpr' Outer + +-- | Parses a type expression in non-top-level contexts, where an unparenthesized type constructor +-- application is acceptable. +-- +-- @since 2.17.1.0 +innerTypeExpr :: ((MonadParsec e String) m) => m TypeExpr +innerTypeExpr = typeExpr' Inner + +data IsInner = Inner | Outer + +typeExpr' :: ((MonadParsec e String) m) => IsInner -> m TypeExpr +typeExpr' isInner = label "type expression" $ do + let + validEmbeddedApplications = case isInner of + Inner -> + [ simpleTypeApplication + , complexTypeApplication + ] + Outer -> [nullaryTypeApplication] + choice $ + validEmbeddedApplications + ++ [ whitespaceBetween '(' ')' innerTypeExpr + , listType + , typeLitPromotedConstructor + , typeLitString + , typeLitInt + ] + where + -- This is a proper subset of `simpleTypeApplication`. + nullaryTypeApplication :: ((MonadParsec e String) m) => m TypeExpr + nullaryTypeApplication = do + tc <- typeConstructor <* optional hspace + pure $ TypeApplication (TypeConstructorExpr tc) [] + +-- This does not parse sugary constructors such as the List constructor `[]`. +typeConstructor :: ((MonadParsec e String) m) => m TypeConstructor +typeConstructor = do + first <- upperChar + rest <- many $ choice [alphaNumChar, char '.', char '\''] + pure $ TypeConstructor (first : rest) + +whitespaceBetween :: ((MonadParsec e String) m) => Char -> Char -> m a -> m a +whitespaceBetween ldelim rdelim = + between (char ldelim *> optional hspace) (optional hspace *> char rdelim) + +complexTypeApplication :: ((MonadParsec e String) m) => m TypeExpr +complexTypeApplication = do + t <- whitespaceBetween '(' ')' innerTypeExpr <* hspace + args <- some (typeExpr <* optional hspace) + pure $ TypeApplication t args + +simpleTypeApplication :: ((MonadParsec e String) m) => m TypeExpr +simpleTypeApplication = do + tc <- typeConstructor <* optional hspace + args <- many (typeExpr <* optional hspace) + pure $ TypeApplication (TypeConstructorExpr tc) args + +typeLitString :: ((MonadParsec e String) m) => m TypeExpr +typeLitString = do + s <- char '"' *> manyTill L.charLiteral (char '"') + pure $ TypeLitString s + +typeLitInt :: ((MonadParsec e String) m) => m TypeExpr +typeLitInt = TypeLitInt <$> some digitChar + +typeLitPromotedConstructor :: ((MonadParsec e String) m) => m TypeExpr +typeLitPromotedConstructor = do + _ <- char '\'' <* optional hspace + TypeLitPromotedConstructor <$> typeConstructor + +listType :: ((MonadParsec e String) m) => m TypeExpr +listType = do + t <- whitespaceBetween '[' ']' innerTypeExpr + pure $ TypeApplication (TypeConstructorExpr ListConstructor) [t] + +-- | Given a TypeExpr, renders it back to a String in a canonical form that looks +-- normal to humans and is re-parseable when making an UnboundEntityDef that uses it. +-- +-- @since 2.17.1.0 +typeExprContent :: TypeExpr -> Text +typeExprContent = typeExprContent' Outer + +-- This is a little gnarly-looking. That's mostly due to attempting to avoid inserting +-- superfluous parentheses. +typeExprContent' :: IsInner -> TypeExpr -> Text +typeExprContent' isInner = \case + TypeLitString s -> + mconcat + [ "\"" + , T.pack s + , "\"" + ] + TypeLitInt s -> T.pack s + TypeLitPromotedConstructor tc -> "'" <> typeExprContent' isInner (TypeConstructorExpr tc) + TypeConstructorExpr (TypeConstructor s) -> T.pack s + TypeConstructorExpr ListConstructor -> "List" + TypeApplication (TypeConstructorExpr tc) args -> simpleTypeApplicationContent tc args isInner + TypeApplication t exps -> + mconcat + [ typeExprContent' Inner t + , " " + , T.intercalate " " $ fmap typeExprContent exps + ] + where + typeArgsListContent :: IsInner -> [TypeExpr] -> Text + typeArgsListContent i exps = T.intercalate " " $ fmap (typeExprContent' i) exps + + simpleTypeApplicationContent :: TypeConstructor -> [TypeExpr] -> IsInner -> Text + simpleTypeApplicationContent ListConstructor args _ = + mconcat + [ "[" + , typeArgsListContent Outer args + , "]" + ] + simpleTypeApplicationContent (TypeConstructor s) [] _ = T.pack s + simpleTypeApplicationContent (TypeConstructor s) exps Inner = + mconcat + [ "(" + , simpleTypeApplicationContent (TypeConstructor s) exps Outer + , ")" + ] + simpleTypeApplicationContent (TypeConstructor s) exps Outer = + mconcat + [ T.pack s + , " " + , typeArgsListContent Inner exps + ] diff --git a/Database/Persist/Quasi/PersistSettings.hs b/Database/Persist/Quasi/PersistSettings.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/PersistSettings.hs @@ -0,0 +1,27 @@ +module Database.Persist.Quasi.PersistSettings + ( PersistSettings + , defaultPersistSettings + , upperCaseSettings + , lowerCaseSettings + , ParserErrorLevel (..) + , ParserWarning + , warningPos + , parserWarningMessage + + -- ** Getters and Setters + , getPsToDBName + , setPsToDBName + , setPsToFKName + , setPsUseSnakeCaseForeignKeys + , setPsUseSnakeCaseForiegnKeys + , getPsStrictFields + , setPsStrictFields + , getPsIdName + , setPsIdName + , getPsTabErrorLevel + , setPsTabErrorLevel + , getPsQuotedArgumentErrorLevel + , setPsQuotedArgumentErrorLevel + ) where + +import Database.Persist.Quasi.PersistSettings.Internal diff --git a/Database/Persist/Quasi/PersistSettings/Internal.hs b/Database/Persist/Quasi/PersistSettings/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Quasi/PersistSettings/Internal.hs @@ -0,0 +1,208 @@ +module Database.Persist.Quasi.PersistSettings.Internal where + +import Data.Char (isDigit, isLower, isSpace, isUpper, toLower) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Void (Void) +import Database.Persist.Names +import Database.Persist.Types +import Text.Megaparsec + ( ParseError + , ParseErrorBundle (..) + , PosState + , SourcePos + , errorBundlePretty + , pstateSourcePos + ) + +data PersistSettings = PersistSettings + { psToDBName :: !(Text -> Text) + -- ^ Modify the Haskell-style name into a database-style name. + , psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text) + -- ^ A function for generating the constraint name, with access to + -- the entity and constraint names. Default value: @mappend@ + -- + -- @since 2.13.0.0 + , psStrictFields :: !Bool + -- ^ Whether fields are by default strict. Default value: @True@. + -- + -- @since 1.2 + , psIdName :: !Text + -- ^ The name of the id column. Default value: @id@ + -- The name of the id column can also be changed on a per-model basis + -- + -- + -- @since 2.0 + , psTabErrorLevel :: Maybe ParserErrorLevel + -- ^ 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 +defaultPersistSettings = + PersistSettings + { psToDBName = id + , psToFKName = \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName + , psStrictFields = True + , psIdName = "id" + , psTabErrorLevel = Just LevelWarning + , psQuotedArgumentErrorLevel = Just LevelWarning + } +upperCaseSettings = defaultPersistSettings +lowerCaseSettings = + defaultPersistSettings + { psToDBName = + let + go c + | isUpper c = T.pack ['_', toLower c] + | otherwise = T.singleton c + in + T.dropWhile (== '_') . T.concatMap go + } + +-- | +-- +-- @since 2.16.0.0 +data ParserErrorLevel = LevelError | LevelWarning deriving (Eq, Show) + +-- | +-- +-- @since 2.16.0.0 +data ParserWarning = ParserWarning + { parserWarningExtraMessage :: String + , parserWarningUnderlyingError :: ParseError String Void + , parserWarningPosState :: PosState String + } + deriving (Eq, Show) + +warningPos :: ParserWarning -> SourcePos +warningPos = pstateSourcePos . parserWarningPosState + +instance Ord ParserWarning where + l <= r = + if warningPos l == warningPos r + then parserWarningMessage l <= parserWarningMessage r + else warningPos l <= warningPos r + +-- | Uses @errorBundlePretty@ to render a parser warning. +-- +-- @since 2.16.0.0 +parserWarningMessage :: ParserWarning -> String +parserWarningMessage pw = + parserWarningExtraMessage pw + <> ( errorBundlePretty $ + ParseErrorBundle + { bundleErrors = parserWarningUnderlyingError pw :| [] + , bundlePosState = parserWarningPosState pw + } + ) + +toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text +toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) = + entName <> inf <> conName + +-- | Retrieve the function in the 'PersistSettings' that modifies the names into +-- database names. +-- +-- @since 2.13.0.0 +getPsToDBName :: PersistSettings -> Text -> Text +getPsToDBName = psToDBName + +-- | Set the name modification function that translates the QuasiQuoted names +-- for use in the database. +-- +-- @since 2.13.0.0 +setPsToDBName :: (Text -> Text) -> PersistSettings -> PersistSettings +setPsToDBName f ps = ps{psToDBName = f} + +-- | Set a custom function used to create the constraint name +-- for a foreign key. +-- +-- @since 2.13.0.0 +setPsToFKName + :: (EntityNameHS -> ConstraintNameHS -> Text) -> PersistSettings -> PersistSettings +setPsToFKName setter ps = ps{psToFKName = setter} + +-- | A preset configuration function that puts an underscore +-- between the entity name and the constraint name when +-- creating a foreign key constraint name +-- +-- @since 2.14.2.0 +setPsUseSnakeCaseForeignKeys :: PersistSettings -> PersistSettings +setPsUseSnakeCaseForeignKeys = setPsToFKName (toFKNameInfixed "_") + +-- | Equivalent to 'setPsUseSnakeCaseForeignKeys', but misspelled. +-- +-- @since 2.13.0.0 +setPsUseSnakeCaseForiegnKeys :: PersistSettings -> PersistSettings +setPsUseSnakeCaseForiegnKeys = setPsUseSnakeCaseForeignKeys +{-# DEPRECATED + setPsUseSnakeCaseForiegnKeys + "use the correctly spelled, equivalent, setPsUseSnakeCaseForeignKeys instead" + #-} + +-- | Retrieve whether or not the 'PersistSettings' will generate code with +-- strict fields. +-- +-- @since 2.13.0.0 +getPsStrictFields :: PersistSettings -> Bool +getPsStrictFields = psStrictFields + +-- | Set whether or not the 'PersistSettings' will make fields strict. +-- +-- @since 2.13.0.0 +setPsStrictFields :: Bool -> PersistSettings -> PersistSettings +setPsStrictFields a ps = ps{psStrictFields = a} + +-- | Retrieve the default name of the @id@ column. +-- +-- @since 2.13.0.0 +getPsIdName :: PersistSettings -> Text +getPsIdName = psIdName + +-- | Set the default name of the @id@ column. +-- +-- @since 2.13.0.0 +setPsIdName :: Text -> PersistSettings -> PersistSettings +setPsIdName n ps = ps{psIdName = n} + +-- | Retrieve the severity of the error generated when the parser encounters a tab. +-- If it is @Nothing@, tabs are permitted in entity definitions. +-- +-- @since 2.16.0.0 +getPsTabErrorLevel :: PersistSettings -> Maybe ParserErrorLevel +getPsTabErrorLevel = psTabErrorLevel + +-- | Set the severity of the error generated when the parser encounters a tab. +-- If set to @Nothing@, tabs are permitted in entity definitions. +-- +-- @since 2.16.0.0 +setPsTabErrorLevel + :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings +setPsTabErrorLevel l ps = ps{psTabErrorLevel = l} + +-- | Retrieve the severity of the error generated when the parser encounters a +-- quoted entity field attribute or quoted directive argument. +-- If it is @Nothing@, quoted arguments are permitted in both entity field +-- definitions and directives. +-- +-- @since 2.17.1.0 +getPsQuotedArgumentErrorLevel :: PersistSettings -> Maybe ParserErrorLevel +getPsQuotedArgumentErrorLevel = psQuotedArgumentErrorLevel + +-- | Set the severity of the error generated when the parser encounters a +-- quoted entity field attribute. +-- If set to @Nothing@, quoted arguments are permitted in both entity field +-- definitions and directives. +-- +-- @since 2.17.1.0 +setPsQuotedArgumentErrorLevel + :: Maybe ParserErrorLevel -> PersistSettings -> PersistSettings +setPsQuotedArgumentErrorLevel l ps = ps{psQuotedArgumentErrorLevel = l} diff --git a/Database/Persist/Sql.hs b/Database/Persist/Sql.hs --- a/Database/Persist/Sql.hs +++ b/Database/Persist/Sql.hs @@ -1,39 +1,90 @@ +-- | This module is the primary entry point if you're working with @persistent@ +-- on a SQL database. +-- +-- = Getting Started +-- +-- First, you'll want to define your database entities. You can do that with +-- "Database.Persist.Quasi." +-- +-- Then, you'll use the operations module Database.Persist.Sql - ( module Database.Persist.Sql.Types - , module Database.Persist.Sql.Class + ( -- * 'RawSql' and 'PersistFieldSql' + module Database.Persist.Sql.Class + + -- * Running actions + + -- | Run actions in a transaction with 'runSqlPool'. , module Database.Persist.Sql.Run + + -- * Migrations , module Database.Persist.Sql.Migration + + -- * @persistent@ combinators + + -- | We re-export "Database.Persist" here, to make it easier to use query + -- and update combinators. Check out that module for documentation. , module Database.Persist , module Database.Persist.Sql.Orphan.PersistStore + + -- * The Escape Hatch + + -- | @persistent@ offers a set of functions that are useful for operating + -- directly on the underlying SQL database. This can allow you to use + -- whatever SQL features you want. + -- + -- Consider going to for a more powerful SQL query library built on @persistent@. , rawQuery , rawQueryRes , rawExecute , rawExecuteCount , rawSql + + -- * SQL helpers , deleteWhereCount , updateWhereCount + , filterClause + , filterClauseWithVals + , orderClause + , FilterTablePrefix (..) + + -- * Transactions , transactionSave , transactionSaveWithIsolation , transactionUndo , transactionUndoWithIsolation - , IsolationLevel (..) + + -- * Other utilities , getStmtConn + , mkColumns + , BackendSpecificOverrides + , emptyBackendSpecificOverrides + , getBackendSpecificForeignKeyName + , setBackendSpecificForeignKeyName + , getBackendSpecificForeignKeyCascadeDefault + , setBackendSpecificForeignKeyCascadeDefault + , defaultAttribute + -- * Internal - , module Database.Persist.Sql.Internal + , IsolationLevel (..) , decorateSQLWithLimitOffset + , module Database.Persist.Sql.Types ) where import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask) import Database.Persist -import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel (..)) import Database.Persist.Sql.Class -import Database.Persist.Sql.Run hiding (withResourceTimeout, rawAcquireSqlConn) -import Database.Persist.Sql.Raw -import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal +import Database.Persist.Sql.Migration +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) +import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal + ( IsolationLevel (..) + , SqlBackend (..) + ) import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore @@ -44,19 +95,22 @@ -- (which brackets its provided action with a transaction begin/commit pair). -- -- @since 1.2.0 -transactionSave :: MonadIO m => ReaderT SqlBackend m () +transactionSave :: (MonadIO m) => ReaderT SqlBackend m () transactionSave = do conn <- ask - let getter = getStmtConn conn + let + getter = getStmtConn conn liftIO $ connCommit conn getter >> connBegin conn getter Nothing -- | Commit the current transaction and begin a new one with the specified isolation level. -- -- @since 2.9.0 -transactionSaveWithIsolation :: MonadIO m => IsolationLevel -> ReaderT SqlBackend m () +transactionSaveWithIsolation + :: (MonadIO m) => IsolationLevel -> ReaderT SqlBackend m () transactionSaveWithIsolation isolation = do conn <- ask - let getter = getStmtConn conn + let + getter = getStmtConn conn liftIO $ connCommit conn getter >> connBegin conn getter (Just isolation) -- | Roll back the current transaction and begin a new one. @@ -64,17 +118,20 @@ -- 'runSqlConn' call. -- -- @since 1.2.0 -transactionUndo :: MonadIO m => ReaderT SqlBackend m () +transactionUndo :: (MonadIO m) => ReaderT SqlBackend m () transactionUndo = do conn <- ask - let getter = getStmtConn conn + let + getter = getStmtConn conn liftIO $ connRollback conn getter >> connBegin conn getter Nothing -- | Roll back the current transaction and begin a new one with the specified isolation level. -- -- @since 2.9.0 -transactionUndoWithIsolation :: MonadIO m => IsolationLevel -> ReaderT SqlBackend m () +transactionUndoWithIsolation + :: (MonadIO m) => IsolationLevel -> ReaderT SqlBackend m () transactionUndoWithIsolation isolation = do conn <- ask - let getter = getStmtConn conn + let + getter = getStmtConn conn liftIO $ connRollback conn getter >> connBegin conn getter (Just isolation) diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -1,497 +1,15266 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} - -module Database.Persist.Sql.Class - ( RawSql (..) - , PersistFieldSql (..) - , EntityWithPrefix(..) - , unPrefix - ) where - -import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) -import Data.Bits (bitSizeMaybe) -import Data.ByteString (ByteString) -import Data.Fixed -import Data.Int -import qualified Data.IntMap as IM -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy(..)) -import qualified Data.Set as S -import Data.Text (Text, intercalate, pack) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Time (UTCTime, TimeOfDay, Day) -import qualified Data.Vector as V -import Data.Word -import Numeric.Natural (Natural) -import Text.Blaze.Html (Html) - -import Database.Persist -import Database.Persist.Sql.Types - - --- | Class for data types that may be retrived from a 'rawSql' --- query. -class RawSql a where - -- | Number of columns that this data type needs and the list - -- of substitutions for @SELECT@ placeholders @??@. - rawSqlCols :: (DBName -> Text) -> a -> (Int, [Text]) - - -- | A string telling the user why the column count is what - -- it is. - rawSqlColCountReason :: a -> String - - -- | Transform a row of the result into the data type. - rawSqlProcessRow :: [PersistValue] -> Either Text a - -instance PersistField a => RawSql (Single a) where - rawSqlCols _ _ = (1, []) - rawSqlColCountReason _ = "one column for a 'Single' data type" - rawSqlProcessRow [pv] = Single <$> fromPersistValue pv - rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." - -instance - (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) => - RawSql (Key a) where - rawSqlCols _ key = (length $ keyToValues key, []) - rawSqlColCountReason key = "The primary key is composed of " - ++ (show $ length $ keyToValues key) - ++ " columns" - rawSqlProcessRow = keyFromValues - -instance - (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) => - RawSql (Entity record) where - rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) - where - sqlFields = map (((name <> ".") <>) . escape) - $ map fieldDB - -- Hacky for a composite key because - -- it selects the same field multiple times - $ entityKeyFields entDef ++ entityFields entDef - name = escape (entityDB entDef) - entDef = entityDef (Nothing :: Maybe record) - rawSqlColCountReason a = - case fst (rawSqlCols (error "RawSql") a) of - 1 -> "one column for an 'Entity' data type without fields" - n -> show n ++ " columns for an 'Entity' data type" - rawSqlProcessRow row = case splitAt nKeyFields row of - (rowKey, rowVal) -> Entity <$> keyFromValues rowKey - <*> fromPersistValues rowVal - where - nKeyFields = length $ entityKeyFields entDef - entDef = entityDef (Nothing :: Maybe record) - --- | This newtype wrapper is useful when selecting an entity out of the --- database and you want to provide a prefix to the table being selected. --- --- Consider this raw SQL query: --- --- > SELECT ?? --- > FROM my_long_table_name AS mltn --- > INNER JOIN other_table AS ot --- > ON mltn.some_col = ot.other_col --- > WHERE ... --- --- We don't want to refer to @my_long_table_name@ every time, so we create --- an alias. If we want to select it, we have to tell the raw SQL --- quasi-quoter that we expect the entity to be prefixed with some other --- name. --- --- We can give the above query a type with this, like: --- --- @ --- getStuff :: 'SqlPersistM' ['EntityWithPrefix' \"mltn\" MyLongTableName] --- getStuff = rawSql queryText [] --- @ --- --- The 'EntityWithPrefix' bit is a boilerplate newtype wrapper, so you can --- remove it with 'unPrefix', like this: --- --- @ --- getStuff :: 'SqlPersistM' ['Entity' MyLongTableName] --- getStuff = 'unPrefix' @\"mltn\" '<$>' 'rawSql' queryText [] --- @ --- --- The @ symbol is a "type application" and requires the @TypeApplications@ --- language extension. --- --- @since 2.10.5 -newtype EntityWithPrefix (prefix :: Symbol) record - = EntityWithPrefix { unEntityWithPrefix :: Entity record } - --- | A helper function to tell GHC what the 'EntityWithPrefix' prefix --- should be. This allows you to use a type application to specify the --- prefix, instead of specifying the etype on the result. --- --- As an example, here's code that uses this: --- --- @ --- myQuery :: 'SqlPersistM' ['Entity' Person] --- myQuery = map (unPrefix @\"p\") <$> rawSql query [] --- where --- query = "SELECT ?? FROM person AS p" --- @ --- --- @since 2.10.5 -unPrefix :: forall prefix record. EntityWithPrefix prefix record -> Entity record -unPrefix = unEntityWithPrefix - -instance - ( PersistEntity record - , KnownSymbol prefix - , PersistEntityBackend record ~ backend - , IsPersistBackend backend - ) - => RawSql (EntityWithPrefix prefix record) where - rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) - where - sqlFields = map (((name <> ".") <>) . escape) - $ map fieldDB - -- Hacky for a composite key because - -- it selects the same field multiple times - $ entityKeyFields entDef ++ entityFields entDef - name = pack $ symbolVal (Proxy :: Proxy prefix) - entDef = entityDef (Nothing :: Maybe record) - rawSqlColCountReason a = - case fst (rawSqlCols (error "RawSql") a) of - 1 -> "one column for an 'Entity' data type without fields" - n -> show n ++ " columns for an 'Entity' data type" - rawSqlProcessRow row = case splitAt nKeyFields row of - (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey - <*> fromPersistValues rowVal - where - nKeyFields = length $ entityKeyFields entDef - entDef = entityDef (Nothing :: Maybe record) - --- | @since 1.0.1 -instance RawSql a => RawSql (Maybe a) where - rawSqlCols e = rawSqlCols e . extractMaybe - rawSqlColCountReason = rawSqlColCountReason . extractMaybe - rawSqlProcessRow cols - | all isNull cols = return Nothing - | otherwise = - case rawSqlProcessRow cols of - Right v -> Right (Just v) - Left msg -> Left $ "RawSql (Maybe a): not all columns were Null " <> - "but the inner parser has failed. Its message " <> - "was \"" <> msg <> "\". Did you apply Maybe " <> - "to a tuple, perhaps? The main use case for " <> - "Maybe is to allow OUTER JOINs to be written, " <> - "in which case 'Maybe (Entity v)' is used." - where isNull PersistNull = True - isNull _ = False - -instance (RawSql a, RawSql b) => RawSql (a, b) where - rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x) - where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta ++ lstb) - rawSqlColCountReason x = rawSqlColCountReason (fst x) ++ ", " ++ - rawSqlColCountReason (snd x) - rawSqlProcessRow = - let x = getType processRow - getType :: (z -> Either y x) -> x - getType = error "RawSql.getType" - - colCountFst = fst $ rawSqlCols (error "RawSql.getType2") (fst x) - processRow row = - let (rowFst, rowSnd) = splitAt colCountFst row - in (,) <$> rawSqlProcessRow rowFst - <*> rawSqlProcessRow rowSnd - - in colCountFst `seq` processRow - -- Avoids recalculating 'colCountFst'. - -instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where - rawSqlCols e = rawSqlCols e . from3 - rawSqlColCountReason = rawSqlColCountReason . from3 - rawSqlProcessRow = fmap to3 . rawSqlProcessRow - -from3 :: (a,b,c) -> ((a,b),c) -from3 (a,b,c) = ((a,b),c) - -to3 :: ((a,b),c) -> (a,b,c) -to3 ((a,b),c) = (a,b,c) - -instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where - rawSqlCols e = rawSqlCols e . from4 - rawSqlColCountReason = rawSqlColCountReason . from4 - rawSqlProcessRow = fmap to4 . rawSqlProcessRow - -from4 :: (a,b,c,d) -> ((a,b),(c,d)) -from4 (a,b,c,d) = ((a,b),(c,d)) - -to4 :: ((a,b),(c,d)) -> (a,b,c,d) -to4 ((a,b),(c,d)) = (a,b,c,d) - -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e) - => RawSql (a, b, c, d, e) where - rawSqlCols e = rawSqlCols e . from5 - rawSqlColCountReason = rawSqlColCountReason . from5 - rawSqlProcessRow = fmap to5 . rawSqlProcessRow - -from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e) -from5 (a,b,c,d,e) = ((a,b),(c,d),e) - -to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) -to5 ((a,b),(c,d),e) = (a,b,c,d,e) - -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f) - => RawSql (a, b, c, d, e, f) where - rawSqlCols e = rawSqlCols e . from6 - rawSqlColCountReason = rawSqlColCountReason . from6 - rawSqlProcessRow = fmap to6 . rawSqlProcessRow - -from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f)) -from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f)) - -to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) -to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) - -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f, - RawSql g) - => RawSql (a, b, c, d, e, f, g) where - rawSqlCols e = rawSqlCols e . from7 - rawSqlColCountReason = rawSqlColCountReason . from7 - rawSqlProcessRow = fmap to7 . rawSqlProcessRow - -from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g) -from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g) - -to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) -to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) - -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f, - RawSql g, RawSql h) - => RawSql (a, b, c, d, e, f, g, h) where - rawSqlCols e = rawSqlCols e . from8 - rawSqlColCountReason = rawSqlColCountReason . from8 - rawSqlProcessRow = fmap to8 . rawSqlProcessRow - -from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h)) -from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h)) - -to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) -to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) - --- | @since 2.10.2 -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f, - RawSql g, RawSql h, RawSql i) - => RawSql (a, b, c, d, e, f, g, h, i) where - rawSqlCols e = rawSqlCols e . from9 - rawSqlColCountReason = rawSqlColCountReason . from9 - rawSqlProcessRow = fmap to9 . rawSqlProcessRow - --- | @since 2.10.2 -from9 :: (a,b,c,d,e,f,g,h,i) -> ((a,b),(c,d),(e,f),(g,h),i) -from9 (a,b,c,d,e,f,g,h,i) = ((a,b),(c,d),(e,f),(g,h),i) - --- | @since 2.10.2 -to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i) -to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i) - --- | @since 2.10.2 -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f, - RawSql g, RawSql h, RawSql i, - RawSql j) - => RawSql (a, b, c, d, e, f, g, h, i, j) where - rawSqlCols e = rawSqlCols e . from10 - rawSqlColCountReason = rawSqlColCountReason . from10 - rawSqlProcessRow = fmap to10 . rawSqlProcessRow - --- | @since 2.10.2 -from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j)) -from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j)) - --- | @since 2.10.2 -to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j) -to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j) - --- | @since 2.10.2 -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f, - RawSql g, RawSql h, RawSql i, - RawSql j, RawSql k) - => RawSql (a, b, c, d, e, f, g, h, i, j, k) where - rawSqlCols e = rawSqlCols e . from11 - rawSqlColCountReason = rawSqlColCountReason . from11 - rawSqlProcessRow = fmap to11 . rawSqlProcessRow - --- | @since 2.10.2 -from11 :: (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b),(c,d),(e,f),(g,h),(i,j),k) -from11 (a,b,c,d,e,f,g,h,i,j,k) = ((a,b),(c,d),(e,f),(g,h),(i,j),k) - --- | @since 2.10.2 -to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) -to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) - --- | @since 2.10.2 -instance (RawSql a, RawSql b, RawSql c, - RawSql d, RawSql e, RawSql f, - RawSql g, RawSql h, RawSql i, - RawSql j, RawSql k, RawSql l) - => RawSql (a, b, c, d, e, f, g, h, i, j, k, l) where - rawSqlCols e = rawSqlCols e . from12 - rawSqlColCountReason = rawSqlColCountReason . from12 - rawSqlProcessRow = fmap to12 . rawSqlProcessRow - --- | @since 2.10.2 -from12 :: (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -from12 (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) - --- | @since 2.10.2 -to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) -to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) - -extractMaybe :: Maybe a -> a -extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe") - --- | Tells Persistent what database column type should be used to store a Haskell type. --- --- ==== __Examples__ --- --- ===== Simple Boolean Alternative --- --- @ --- data Switch = On | Off --- deriving (Show, Eq) --- --- instance 'PersistField' Switch where --- 'toPersistValue' s = case s of --- On -> 'PersistBool' True --- Off -> 'PersistBool' False --- 'fromPersistValue' ('PersistBool' b) = if b then 'Right' On else 'Right' Off --- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a Switch: expected PersistBool, received: " <> T.pack (show x) --- --- instance 'PersistFieldSql' Switch where --- 'sqlType' _ = 'SqlBool' --- @ --- --- ===== Non-Standard Database Types --- --- If your database supports non-standard types, such as Postgres' @uuid@, you can use 'SqlOther' to use them: --- --- @ --- import qualified Data.UUID as UUID --- instance 'PersistField' UUID where --- 'toPersistValue' = 'PersistDbSpecific' . toASCIIBytes --- 'fromPersistValue' ('PersistDbSpecific' uuid) = --- case fromASCIIBytes uuid of --- 'Nothing' -> 'Left' $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid) --- 'Just' uuid' -> 'Right' uuid' --- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistDbSpecific, received: "-- > <> T.pack (show x) --- --- instance 'PersistFieldSql' UUID where --- 'sqlType' _ = 'SqlOther' "uuid" --- @ --- --- ===== User Created Database Types --- --- Similarly, some databases support creating custom types, e.g. Postgres' and features. You can use 'SqlOther' to specify a custom type: --- --- > CREATE DOMAIN ssn AS text --- > CHECK ( value ~ '^[0-9]{9}$'); --- --- @ --- instance 'PersistFieldSQL' SSN where --- 'sqlType' _ = 'SqlOther' "ssn" --- @ --- --- > CREATE TYPE rainbow_color AS ENUM ('red', 'orange', 'yellow', 'green', 'blue', 'indigo', 'violet'); --- --- @ --- instance 'PersistFieldSQL' RainbowColor where --- 'sqlType' _ = 'SqlOther' "rainbow_color" --- @ -class PersistField a => PersistFieldSql a where - sqlType :: Proxy a -> SqlType - -#ifndef NO_OVERLAP -instance {-# OVERLAPPING #-} PersistFieldSql [Char] where - sqlType _ = SqlString -#endif - -instance PersistFieldSql ByteString where - sqlType _ = SqlBlob -instance PersistFieldSql T.Text where - sqlType _ = SqlString -instance PersistFieldSql TL.Text where - sqlType _ = SqlString -instance PersistFieldSql Html where - sqlType _ = SqlString -instance PersistFieldSql Int where - sqlType _ - | Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32 - | otherwise = SqlInt64 -instance PersistFieldSql Int8 where - sqlType _ = SqlInt32 -instance PersistFieldSql Int16 where - sqlType _ = SqlInt32 -instance PersistFieldSql Int32 where - sqlType _ = SqlInt32 -instance PersistFieldSql Int64 where - sqlType _ = SqlInt64 -instance PersistFieldSql Word where - sqlType _ = SqlInt64 -instance PersistFieldSql Word8 where - sqlType _ = SqlInt32 -instance PersistFieldSql Word16 where - sqlType _ = SqlInt32 -instance PersistFieldSql Word32 where - sqlType _ = SqlInt64 -instance PersistFieldSql Word64 where - sqlType _ = SqlInt64 -instance PersistFieldSql Double where - sqlType _ = SqlReal -instance PersistFieldSql Bool where - sqlType _ = SqlBool -instance PersistFieldSql Day where - sqlType _ = SqlDay -instance PersistFieldSql TimeOfDay where - sqlType _ = SqlTime -instance PersistFieldSql UTCTime where - sqlType _ = SqlDayTime -instance {-# OVERLAPPABLE #-} PersistFieldSql a => PersistFieldSql [a] where - sqlType _ = SqlString -instance PersistFieldSql a => PersistFieldSql (V.Vector a) where - sqlType _ = SqlString -instance (Ord a, PersistFieldSql a) => PersistFieldSql (S.Set a) where - sqlType _ = SqlString -instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (a,b) where - sqlType _ = SqlString -instance PersistFieldSql v => PersistFieldSql (IM.IntMap v) where - sqlType _ = SqlString -instance PersistFieldSql v => PersistFieldSql (M.Map T.Text v) where - sqlType _ = SqlString -instance PersistFieldSql PersistValue where - sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64 -instance PersistFieldSql Checkmark where - sqlType _ = SqlBool -instance (HasResolution a) => PersistFieldSql (Fixed a) where - sqlType a = - SqlNumeric long prec - where - prec = round $ (log $ fromIntegral $ resolution n) / (log 10 :: Double) -- FIXME: May lead to problems with big numbers - long = prec + 10 -- FIXME: Is this enough ? - n = 0 - _mn = return n `asTypeOf` a -instance PersistFieldSql Rational where - sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC - -instance PersistFieldSql Natural where - sqlType _ = SqlInt64 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.Sql.Class + ( RawSql (..) + , PersistFieldSql (..) + , EntityWithPrefix (..) + , unPrefix + ) where + +import Data.Bits (bitSizeMaybe) +import Data.ByteString (ByteString) +import Data.Fixed +import Data.Foldable (toList) +import Data.Int +import qualified Data.IntMap as IM +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import qualified Data.Set as S +import Data.Text (Text, intercalate, pack) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Time (Day, TimeOfDay, UTCTime) +import qualified Data.Vector as V +import Data.Word +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Text.Blaze.Html (Html) + +import Database.Persist +import Database.Persist.Sql.Types + +-- | Class for data types that may be retrived from a 'rawSql' +-- query. +class RawSql a where + -- | Number of columns that this data type needs and the list + -- of substitutions for @SELECT@ placeholders @??@. + rawSqlCols :: (Text -> Text) -> a -> (Int, [Text]) + + -- | A string telling the user why the column count is what + -- it is. + rawSqlColCountReason :: a -> String + + -- | Transform a row of the result into the data type. + rawSqlProcessRow :: [PersistValue] -> Either Text a + +instance (PersistField a) => RawSql (Single a) where + rawSqlCols _ _ = (1, []) + rawSqlColCountReason _ = "one column for a 'Single' data type" + rawSqlProcessRow [pv] = Single <$> fromPersistValue pv + rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." + +instance + (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) + => RawSql (Key a) + where + rawSqlCols _ key = (length $ keyToValues key, []) + rawSqlColCountReason key = + "The primary key is composed of " + ++ (show $ length $ keyToValues key) + ++ " columns" + rawSqlProcessRow = keyFromValues + +instance + ( PersistEntity record + , PersistEntityBackend record ~ backend + , IsPersistBackend backend + ) + => RawSql (Entity record) + where + rawSqlCols escape _ent = (length sqlFields, [intercalate ", " $ toList sqlFields]) + where + sqlFields = + fmap (((name <> ".") <>) . escapeWith escape) $ + fmap fieldDB $ + keyAndEntityFields entDef + name = + escapeWith escape (getEntityDBName entDef) + entDef = + entityDef (Nothing :: Maybe record) + rawSqlColCountReason a = + case fst (rawSqlCols (error "RawSql") a) of + 1 -> "one column for an 'Entity' data type without fields" + n -> show n <> " columns for an 'Entity' data type" + rawSqlProcessRow row = + case keyFromRecordM of + Just mkKey -> do + val <- fromPersistValues row + pure + Entity + { entityKey = + mkKey val + , entityVal = + val + } + Nothing -> + case row of + (k : rest) -> + Entity + <$> keyFromValues [k] + <*> fromPersistValues rest + [] -> + Left "Row was empty" + +-- | This newtype wrapper is useful when selecting an entity out of the +-- database and you want to provide a prefix to the table being selected. +-- +-- Consider this raw SQL query: +-- +-- > SELECT ?? +-- > FROM my_long_table_name AS mltn +-- > INNER JOIN other_table AS ot +-- > ON mltn.some_col = ot.other_col +-- > WHERE ... +-- +-- We don't want to refer to @my_long_table_name@ every time, so we create +-- an alias. If we want to select it, we have to tell the raw SQL +-- quasi-quoter that we expect the entity to be prefixed with some other +-- name. +-- +-- We can give the above query a type with this, like: +-- +-- @ +-- getStuff :: 'SqlPersistM' ['EntityWithPrefix' \"mltn\" MyLongTableName] +-- getStuff = rawSql queryText [] +-- @ +-- +-- The 'EntityWithPrefix' bit is a boilerplate newtype wrapper, so you can +-- remove it with 'unPrefix', like this: +-- +-- @ +-- getStuff :: 'SqlPersistM' ['Entity' MyLongTableName] +-- getStuff = 'unPrefix' @\"mltn\" '<$>' 'rawSql' queryText [] +-- @ +-- +-- The @ symbol is a "type application" and requires the @TypeApplications@ +-- language extension. +-- +-- @since 2.10.5 +newtype EntityWithPrefix (prefix :: Symbol) record + = EntityWithPrefix {unEntityWithPrefix :: Entity record} + +-- | A helper function to tell GHC what the 'EntityWithPrefix' prefix +-- should be. This allows you to use a type application to specify the +-- prefix, instead of specifying the etype on the result. +-- +-- As an example, here's code that uses this: +-- +-- @ +-- myQuery :: 'SqlPersistM' ['Entity' Person] +-- myQuery = fmap (unPrefix @\"p\") <$> rawSql query [] +-- where +-- query = "SELECT ?? FROM person AS p" +-- @ +-- +-- @since 2.10.5 +unPrefix + :: forall prefix record. EntityWithPrefix prefix record -> Entity record +unPrefix = unEntityWithPrefix + +instance + ( PersistEntity record + , KnownSymbol prefix + , PersistEntityBackend record ~ backend + , IsPersistBackend backend + ) + => RawSql (EntityWithPrefix prefix record) + where + rawSqlCols escape _ent = (length sqlFields, [intercalate ", " $ toList sqlFields]) + where + sqlFields = + fmap (((name <> ".") <>) . escapeWith escape) $ + fmap fieldDB + -- Hacky for a composite key because + -- it selects the same field multiple times + $ + keyAndEntityFields entDef + name = + pack $ symbolVal (Proxy :: Proxy prefix) + entDef = + entityDef (Nothing :: Maybe record) + rawSqlColCountReason a = + case fst (rawSqlCols (error "RawSql") a) of + 1 -> "one column for an 'Entity' data type without fields" + n -> show n ++ " columns for an 'Entity' data type" + rawSqlProcessRow row = + case splitAt nKeyFields row of + (rowKey, rowVal) -> + fmap EntityWithPrefix $ + Entity + <$> keyFromValues rowKey + <*> fromPersistValues rowVal + where + nKeyFields = length $ getEntityKeyFields entDef + entDef = entityDef (Nothing :: Maybe record) + +-- | @since 1.0.1 +instance (RawSql a) => RawSql (Maybe a) where + rawSqlCols e = rawSqlCols e . extractMaybe + rawSqlColCountReason = rawSqlColCountReason . extractMaybe + rawSqlProcessRow cols + | all isNull cols = return Nothing + | otherwise = + case rawSqlProcessRow cols of + Right v -> Right (Just v) + Left msg -> + Left $ + "RawSql (Maybe a): not all columns were Null " + <> "but the inner parser has failed. Its message " + <> "was \"" + <> msg + <> "\". Did you apply Maybe " + <> "to a tuple, perhaps? The main use case for " + <> "Maybe is to allow OUTER JOINs to be written, " + <> "in which case 'Maybe (Entity v)' is used." + where + isNull PersistNull = True + isNull _ = False + +instance (RawSql a, RawSql b) => RawSql (a, b) where + rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x) + where + (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta ++ lstb) + rawSqlColCountReason x = + rawSqlColCountReason (fst x) + ++ ", " + ++ rawSqlColCountReason (snd x) + rawSqlProcessRow = + let + x = getType processRow + getType :: (z -> Either y x) -> x + getType = error "RawSql.getType" + + colCountFst = fst $ rawSqlCols (error "RawSql.getType2") (fst x) + processRow row = + let + (rowFst, rowSnd) = splitAt colCountFst row + in + (,) + <$> rawSqlProcessRow rowFst + <*> rawSqlProcessRow rowSnd + in + colCountFst `seq` processRow + +-- Avoids recalculating 'colCountFst'. + +instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where + rawSqlCols e = rawSqlCols e . from3 + rawSqlColCountReason = rawSqlColCountReason . from3 + rawSqlProcessRow = fmap to3 . rawSqlProcessRow + +from3 :: (a, b, c) -> ((a, b), c) +from3 (a, b, c) = ((a, b), c) + +to3 :: ((a, b), c) -> (a, b, c) +to3 ((a, b), c) = (a, b, c) + +instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where + rawSqlCols e = rawSqlCols e . from4 + rawSqlColCountReason = rawSqlColCountReason . from4 + rawSqlProcessRow = fmap to4 . rawSqlProcessRow + +from4 :: (a, b, c, d) -> ((a, b), (c, d)) +from4 (a, b, c, d) = ((a, b), (c, d)) + +to4 :: ((a, b), (c, d)) -> (a, b, c, d) +to4 ((a, b), (c, d)) = (a, b, c, d) + +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + ) + => RawSql (a, b, c, d, e) + where + rawSqlCols e = rawSqlCols e . from5 + rawSqlColCountReason = rawSqlColCountReason . from5 + rawSqlProcessRow = fmap to5 . rawSqlProcessRow + +from5 :: (a, b, c, d, e) -> ((a, b), (c, d), e) +from5 (a, b, c, d, e) = ((a, b), (c, d), e) + +to5 :: ((a, b), (c, d), e) -> (a, b, c, d, e) +to5 ((a, b), (c, d), e) = (a, b, c, d, e) + +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + ) + => RawSql (a, b, c, d, e, f) + where + rawSqlCols e = rawSqlCols e . from6 + rawSqlColCountReason = rawSqlColCountReason . from6 + rawSqlProcessRow = fmap to6 . rawSqlProcessRow + +from6 :: (a, b, c, d, e, f) -> ((a, b), (c, d), (e, f)) +from6 (a, b, c, d, e, f) = ((a, b), (c, d), (e, f)) + +to6 :: ((a, b), (c, d), (e, f)) -> (a, b, c, d, e, f) +to6 ((a, b), (c, d), (e, f)) = (a, b, c, d, e, f) + +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + ) + => RawSql (a, b, c, d, e, f, g) + where + rawSqlCols e = rawSqlCols e . from7 + rawSqlColCountReason = rawSqlColCountReason . from7 + rawSqlProcessRow = fmap to7 . rawSqlProcessRow + +from7 :: (a, b, c, d, e, f, g) -> ((a, b), (c, d), (e, f), g) +from7 (a, b, c, d, e, f, g) = ((a, b), (c, d), (e, f), g) + +to7 :: ((a, b), (c, d), (e, f), g) -> (a, b, c, d, e, f, g) +to7 ((a, b), (c, d), (e, f), g) = (a, b, c, d, e, f, g) + +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + ) + => RawSql (a, b, c, d, e, f, g, h) + where + rawSqlCols e = rawSqlCols e . from8 + rawSqlColCountReason = rawSqlColCountReason . from8 + rawSqlProcessRow = fmap to8 . rawSqlProcessRow + +from8 :: (a, b, c, d, e, f, g, h) -> ((a, b), (c, d), (e, f), (g, h)) +from8 (a, b, c, d, e, f, g, h) = ((a, b), (c, d), (e, f), (g, h)) + +to8 :: ((a, b), (c, d), (e, f), (g, h)) -> (a, b, c, d, e, f, g, h) +to8 ((a, b), (c, d), (e, f), (g, h)) = (a, b, c, d, e, f, g, h) + +-- | @since 2.10.2 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + ) + => RawSql (a, b, c, d, e, f, g, h, i) + where + rawSqlCols e = rawSqlCols e . from9 + rawSqlColCountReason = rawSqlColCountReason . from9 + rawSqlProcessRow = fmap to9 . rawSqlProcessRow + +-- | @since 2.10.2 +from9 :: (a, b, c, d, e, f, g, h, i) -> ((a, b), (c, d), (e, f), (g, h), i) +from9 (a, b, c, d, e, f, g, h, i) = ((a, b), (c, d), (e, f), (g, h), i) + +-- | @since 2.10.2 +to9 :: ((a, b), (c, d), (e, f), (g, h), i) -> (a, b, c, d, e, f, g, h, i) +to9 ((a, b), (c, d), (e, f), (g, h), i) = (a, b, c, d, e, f, g, h, i) + +-- | @since 2.10.2 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + ) + => RawSql (a, b, c, d, e, f, g, h, i, j) + where + rawSqlCols e = rawSqlCols e . from10 + rawSqlColCountReason = rawSqlColCountReason . from10 + rawSqlProcessRow = fmap to10 . rawSqlProcessRow + +-- | @since 2.10.2 +from10 + :: (a, b, c, d, e, f, g, h, i, j) -> ((a, b), (c, d), (e, f), (g, h), (i, j)) +from10 (a, b, c, d, e, f, g, h, i, j) = ((a, b), (c, d), (e, f), (g, h), (i, j)) + +-- | @since 2.10.2 +to10 + :: ((a, b), (c, d), (e, f), (g, h), (i, j)) -> (a, b, c, d, e, f, g, h, i, j) +to10 ((a, b), (c, d), (e, f), (g, h), (i, j)) = (a, b, c, d, e, f, g, h, i, j) + +-- | @since 2.10.2 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k) + where + rawSqlCols e = rawSqlCols e . from11 + rawSqlColCountReason = rawSqlColCountReason . from11 + rawSqlProcessRow = fmap to11 . rawSqlProcessRow + +-- | @since 2.10.2 +from11 + :: (a, b, c, d, e, f, g, h, i, j, k) -> ((a, b), (c, d), (e, f), (g, h), (i, j), k) +from11 (a, b, c, d, e, f, g, h, i, j, k) = ((a, b), (c, d), (e, f), (g, h), (i, j), k) + +-- | @since 2.10.2 +to11 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), k) -> (a, b, c, d, e, f, g, h, i, j, k) +to11 ((a, b), (c, d), (e, f), (g, h), (i, j), k) = (a, b, c, d, e, f, g, h, i, j, k) + +-- | @since 2.10.2 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l) + where + rawSqlCols e = rawSqlCols e . from12 + rawSqlColCountReason = rawSqlColCountReason . from12 + rawSqlProcessRow = fmap to12 . rawSqlProcessRow + +-- | @since 2.10.2 +from12 + :: (a, b, c, d, e, f, g, h, i, j, k, l) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l)) +from12 (a, b, c, d, e, f, g, h, i, j, k, l) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l)) + +-- | @since 2.10.2 +to12 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l)) + -> (a, b, c, d, e, f, g, h, i, j, k, l) +to12 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l)) = (a, b, c, d, e, f, g, h, i, j, k, l) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m) + where + rawSqlCols e = rawSqlCols e . from13 + rawSqlColCountReason = rawSqlColCountReason . from13 + rawSqlProcessRow = fmap to13 . rawSqlProcessRow + +-- | @since 2.11.0 +from13 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), m) +from13 (a, b, c, d, e, f, g, h, i, j, k, l, m) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), m) + +-- | @since 2.11.0 +to13 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), m) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m) +to13 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), m) = (a, b, c, d, e, f, g, h, i, j, k, l, m) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + where + rawSqlCols e = rawSqlCols e . from14 + rawSqlColCountReason = rawSqlColCountReason . from14 + rawSqlProcessRow = fmap to14 . rawSqlProcessRow + +-- | @since 2.11.0 +from14 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n)) +from14 (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n)) + +-- | @since 2.11.0 +to14 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n)) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n) +to14 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n)) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + where + rawSqlCols e = rawSqlCols e . from15 + rawSqlColCountReason = rawSqlColCountReason . from15 + rawSqlProcessRow = fmap to15 . rawSqlProcessRow + +-- | @since 2.11.0 +from15 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), o) +from15 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), o) + +-- | @since 2.11.0 +to15 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), o) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) +to15 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), o) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + where + rawSqlCols e = rawSqlCols e . from16 + rawSqlColCountReason = rawSqlColCountReason . from16 + rawSqlProcessRow = fmap to16 . rawSqlProcessRow + +-- | @since 2.11.0 +from16 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p)) +from16 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p)) + +-- | @since 2.11.0 +to16 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p)) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) +to16 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p)) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) + where + rawSqlCols e = rawSqlCols e . from17 + rawSqlColCountReason = rawSqlColCountReason . from17 + rawSqlProcessRow = fmap to17 . rawSqlProcessRow + +-- | @since 2.11.0 +from17 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), q) +from17 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), q) + +-- | @since 2.11.0 +to17 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), q) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) +to17 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), q) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) + where + rawSqlCols e = rawSqlCols e . from18 + rawSqlColCountReason = rawSqlColCountReason . from18 + rawSqlProcessRow = fmap to18 . rawSqlProcessRow + +-- | @since 2.11.0 +from18 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r)) +from18 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r)) + +-- | @since 2.11.0 +to18 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r)) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) +to18 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r)) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) + where + rawSqlCols e = rawSqlCols e . from19 + rawSqlColCountReason = rawSqlColCountReason . from19 + rawSqlProcessRow = fmap to19 . rawSqlProcessRow + +-- | @since 2.11.0 +from19 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), s) +from19 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), s) + +-- | @since 2.11.0 +to19 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), s) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) +to19 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), s) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) + where + rawSqlCols e = rawSqlCols e . from20 + rawSqlColCountReason = rawSqlColCountReason . from20 + rawSqlProcessRow = fmap to20 . rawSqlProcessRow + +-- | @since 2.11.0 +from20 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) + -> ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), (s, t)) +from20 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = + ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), (s, t)) + +-- | @since 2.11.0 +to20 + :: ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), (s, t)) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) +to20 ((a, b), (c, d), (e, f), (g, h), (i, j), (k, l), (m, n), (o, p), (q, r), (s, t)) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) + where + rawSqlCols e = rawSqlCols e . from21 + rawSqlColCountReason = rawSqlColCountReason . from21 + rawSqlProcessRow = fmap to21 . rawSqlProcessRow + +-- | @since 2.11.0 +from21 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , u + ) +from21 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , u + ) + +-- | @since 2.11.0 +to21 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , u + ) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) +to21 ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , u + ) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) + where + rawSqlCols e = rawSqlCols e . from22 + rawSqlColCountReason = rawSqlColCountReason . from22 + rawSqlProcessRow = fmap to22 . rawSqlProcessRow + +-- | @since 2.11.0 +from22 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + ) +from22 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + ) + +-- | @since 2.11.0 +to22 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + ) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) +to22 ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + ) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) + where + rawSqlCols e = rawSqlCols e . from23 + rawSqlColCountReason = rawSqlColCountReason . from23 + rawSqlProcessRow = fmap to23 . rawSqlProcessRow + +-- | @since 2.11.0 +from23 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , w + ) +from23 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , w + ) + +-- | @since 2.11.0 +to23 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , w + ) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) +to23 ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , w + ) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + ) + => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) + where + rawSqlCols e = rawSqlCols e . from24 + rawSqlColCountReason = rawSqlColCountReason . from24 + rawSqlProcessRow = fmap to24 . rawSqlProcessRow + +-- | @since 2.11.0 +from24 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + ) +from24 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + ) + +-- | @since 2.11.0 +to24 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + ) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) +to24 ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + ) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + ) + => RawSql + (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) + where + rawSqlCols e = rawSqlCols e . from25 + rawSqlColCountReason = rawSqlColCountReason . from25 + rawSqlProcessRow = fmap to25 . rawSqlProcessRow + +-- | @since 2.11.0 +from25 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , y + ) +from25 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , y + ) + +-- | @since 2.11.0 +to25 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , y + ) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) +to25 ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , y + ) = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + ) + => RawSql + (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) + where + rawSqlCols e = rawSqlCols e . from26 + rawSqlColCountReason = rawSqlColCountReason . from26 + rawSqlProcessRow = fmap to26 . rawSqlProcessRow + +-- | @since 2.11.0 +from26 + :: (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + ) +from26 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + ) + +-- | @since 2.11.0 +to26 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + ) + -> (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) +to26 ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + ) = + (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + ) + where + rawSqlCols e = rawSqlCols e . from27 + rawSqlColCountReason = rawSqlColCountReason . from27 + rawSqlProcessRow = fmap to27 . rawSqlProcessRow + +-- | @since 2.11.0 +from27 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , a2 + ) +from27 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , a2 + ) + +-- | @since 2.11.0 +to27 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , a2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + ) +to27 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , a2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + ) + where + rawSqlCols e = rawSqlCols e . from28 + rawSqlColCountReason = rawSqlColCountReason . from28 + rawSqlProcessRow = fmap to28 . rawSqlProcessRow + +-- | @since 2.11.0 +from28 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + ) +from28 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + ) + +-- | @since 2.11.0 +to28 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + ) +to28 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + ) + where + rawSqlCols e = rawSqlCols e . from29 + rawSqlColCountReason = rawSqlColCountReason . from29 + rawSqlProcessRow = fmap to29 . rawSqlProcessRow + +-- | @since 2.11.0 +from29 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , c2 + ) +from29 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , c2 + ) + +-- | @since 2.11.0 +to29 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , c2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + ) +to29 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , c2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + ) + where + rawSqlCols e = rawSqlCols e . from30 + rawSqlColCountReason = rawSqlColCountReason . from30 + rawSqlProcessRow = fmap to30 . rawSqlProcessRow + +-- | @since 2.11.0 +from30 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + ) +from30 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + ) + +-- | @since 2.11.0 +to30 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + ) +to30 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + ) + where + rawSqlCols e = rawSqlCols e . from31 + rawSqlColCountReason = rawSqlColCountReason . from31 + rawSqlProcessRow = fmap to31 . rawSqlProcessRow + +-- | @since 2.11.0 +from31 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , e2 + ) +from31 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , e2 + ) + +-- | @since 2.11.0 +to31 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , e2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + ) +to31 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , e2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + ) + where + rawSqlCols e = rawSqlCols e . from32 + rawSqlColCountReason = rawSqlColCountReason . from32 + rawSqlProcessRow = fmap to32 . rawSqlProcessRow + +-- | @since 2.11.0 +from32 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + ) +from32 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + ) + +-- | @since 2.11.0 +to32 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + ) +to32 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + ) + where + rawSqlCols e = rawSqlCols e . from33 + rawSqlColCountReason = rawSqlColCountReason . from33 + rawSqlProcessRow = fmap to33 . rawSqlProcessRow + +-- | @since 2.11.0 +from33 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , g2 + ) +from33 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , g2 + ) + +-- | @since 2.11.0 +to33 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , g2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + ) +to33 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , g2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + ) + where + rawSqlCols e = rawSqlCols e . from34 + rawSqlColCountReason = rawSqlColCountReason . from34 + rawSqlProcessRow = fmap to34 . rawSqlProcessRow + +-- | @since 2.11.0 +from34 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + ) +from34 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + ) + +-- | @since 2.11.0 +to34 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + ) +to34 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + ) + where + rawSqlCols e = rawSqlCols e . from35 + rawSqlColCountReason = rawSqlColCountReason . from35 + rawSqlProcessRow = fmap to35 . rawSqlProcessRow + +-- | @since 2.11.0 +from35 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , i2 + ) +from35 ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , i2 + ) + +-- | @since 2.11.0 +to35 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , i2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + ) +to35 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , i2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + ) + where + rawSqlCols e = rawSqlCols e . from36 + rawSqlColCountReason = rawSqlColCountReason . from36 + rawSqlProcessRow = fmap to36 . rawSqlProcessRow + +-- | @since 2.11.0 +from36 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + ) +from36 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + ) + +-- | @since 2.11.0 +to36 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + ) +to36 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + ) + where + rawSqlCols e = rawSqlCols e . from37 + rawSqlColCountReason = rawSqlColCountReason . from37 + rawSqlProcessRow = fmap to37 . rawSqlProcessRow + +-- | @since 2.11.0 +from37 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , k2 + ) +from37 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , k2 + ) + +-- | @since 2.11.0 +to37 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , k2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + ) +to37 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , k2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + ) + where + rawSqlCols e = rawSqlCols e . from38 + rawSqlColCountReason = rawSqlColCountReason . from38 + rawSqlProcessRow = fmap to38 . rawSqlProcessRow + +-- | @since 2.11.0 +from38 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + ) +from38 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + ) + +-- | @since 2.11.0 +to38 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + ) +to38 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + ) + where + rawSqlCols e = rawSqlCols e . from39 + rawSqlColCountReason = rawSqlColCountReason . from39 + rawSqlProcessRow = fmap to39 . rawSqlProcessRow + +-- | @since 2.11.0 +from39 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , m2 + ) +from39 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , m2 + ) + +-- | @since 2.11.0 +to39 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , m2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + ) +to39 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , m2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + ) + where + rawSqlCols e = rawSqlCols e . from40 + rawSqlColCountReason = rawSqlColCountReason . from40 + rawSqlProcessRow = fmap to40 . rawSqlProcessRow + +-- | @since 2.11.0 +from40 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + ) +from40 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + ) + +-- | @since 2.11.0 +to40 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + ) +to40 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + ) + where + rawSqlCols e = rawSqlCols e . from41 + rawSqlColCountReason = rawSqlColCountReason . from41 + rawSqlProcessRow = fmap to41 . rawSqlProcessRow + +-- | @since 2.11.0 +from41 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , o2 + ) +from41 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , o2 + ) + +-- | @since 2.11.0 +to41 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , o2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + ) +to41 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , o2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + ) + where + rawSqlCols e = rawSqlCols e . from42 + rawSqlColCountReason = rawSqlColCountReason . from42 + rawSqlProcessRow = fmap to42 . rawSqlProcessRow + +-- | @since 2.11.0 +from42 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + ) +from42 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + ) + +-- | @since 2.11.0 +to42 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + ) +to42 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + ) + where + rawSqlCols e = rawSqlCols e . from43 + rawSqlColCountReason = rawSqlColCountReason . from43 + rawSqlProcessRow = fmap to43 . rawSqlProcessRow + +-- | @since 2.11.0 +from43 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , q2 + ) +from43 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , q2 + ) + +-- | @since 2.11.0 +to43 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , q2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + ) +to43 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , q2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + ) + where + rawSqlCols e = rawSqlCols e . from44 + rawSqlColCountReason = rawSqlColCountReason . from44 + rawSqlProcessRow = fmap to44 . rawSqlProcessRow + +-- | @since 2.11.0 +from44 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + ) +from44 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + ) + +-- | @since 2.11.0 +to44 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + ) +to44 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + ) + where + rawSqlCols e = rawSqlCols e . from45 + rawSqlColCountReason = rawSqlColCountReason . from45 + rawSqlProcessRow = fmap to45 . rawSqlProcessRow + +-- | @since 2.11.0 +from45 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , s2 + ) +from45 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , s2 + ) + +-- | @since 2.11.0 +to45 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , s2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + ) +to45 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , s2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + ) + where + rawSqlCols e = rawSqlCols e . from46 + rawSqlColCountReason = rawSqlColCountReason . from46 + rawSqlProcessRow = fmap to46 . rawSqlProcessRow + +-- | @since 2.11.0 +from46 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + ) +from46 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + ) + +-- | @since 2.11.0 +to46 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + ) +to46 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + ) + where + rawSqlCols e = rawSqlCols e . from47 + rawSqlColCountReason = rawSqlColCountReason . from47 + rawSqlProcessRow = fmap to47 . rawSqlProcessRow + +-- | @since 2.11.0 +from47 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , u2 + ) +from47 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , u2 + ) + +-- | @since 2.11.0 +to47 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , u2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + ) +to47 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , u2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + ) + where + rawSqlCols e = rawSqlCols e . from48 + rawSqlColCountReason = rawSqlColCountReason . from48 + rawSqlProcessRow = fmap to48 . rawSqlProcessRow + +-- | @since 2.11.0 +from48 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + ) +from48 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + ) + +-- | @since 2.11.0 +to48 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + ) +to48 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + ) + where + rawSqlCols e = rawSqlCols e . from49 + rawSqlColCountReason = rawSqlColCountReason . from49 + rawSqlProcessRow = fmap to49 . rawSqlProcessRow + +-- | @since 2.11.0 +from49 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , w2 + ) +from49 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , w2 + ) + +-- | @since 2.11.0 +to49 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , w2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + ) +to49 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , w2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + ) + where + rawSqlCols e = rawSqlCols e . from50 + rawSqlColCountReason = rawSqlColCountReason . from50 + rawSqlProcessRow = fmap to50 . rawSqlProcessRow + +-- | @since 2.11.0 +from50 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + ) +from50 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + ) + +-- | @since 2.11.0 +to50 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + ) +to50 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + ) + where + rawSqlCols e = rawSqlCols e . from51 + rawSqlColCountReason = rawSqlColCountReason . from51 + rawSqlProcessRow = fmap to51 . rawSqlProcessRow + +-- | @since 2.11.0 +from51 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , y2 + ) +from51 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , y2 + ) + +-- | @since 2.11.0 +to51 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , y2 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + ) +to51 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , y2 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + ) + where + rawSqlCols e = rawSqlCols e . from52 + rawSqlColCountReason = rawSqlColCountReason . from52 + rawSqlProcessRow = fmap to52 . rawSqlProcessRow + +-- | @since 2.11.0 +from52 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + ) +from52 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + ) + +-- | @since 2.11.0 +to52 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + ) +to52 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + ) + where + rawSqlCols e = rawSqlCols e . from53 + rawSqlColCountReason = rawSqlColCountReason . from53 + rawSqlProcessRow = fmap to53 . rawSqlProcessRow + +-- | @since 2.11.0 +from53 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , a3 + ) +from53 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , a3 + ) + +-- | @since 2.11.0 +to53 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , a3 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + ) +to53 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , a3 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + ) + where + rawSqlCols e = rawSqlCols e . from54 + rawSqlColCountReason = rawSqlColCountReason . from54 + rawSqlProcessRow = fmap to54 . rawSqlProcessRow + +-- | @since 2.11.0 +from54 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + ) +from54 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + ) + +-- | @since 2.11.0 +to54 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + ) +to54 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + ) + where + rawSqlCols e = rawSqlCols e . from55 + rawSqlColCountReason = rawSqlColCountReason . from55 + rawSqlProcessRow = fmap to55 . rawSqlProcessRow + +-- | @since 2.11.0 +from55 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , c3 + ) +from55 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , c3 + ) + +-- | @since 2.11.0 +to55 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , c3 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + ) +to55 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , c3 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + ) + where + rawSqlCols e = rawSqlCols e . from56 + rawSqlColCountReason = rawSqlColCountReason . from56 + rawSqlProcessRow = fmap to56 . rawSqlProcessRow + +-- | @since 2.11.0 +from56 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + ) +from56 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + ) + +-- | @since 2.11.0 +to56 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + ) +to56 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + , RawSql e3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + ) + where + rawSqlCols e = rawSqlCols e . from57 + rawSqlColCountReason = rawSqlColCountReason . from57 + rawSqlProcessRow = fmap to57 . rawSqlProcessRow + +-- | @since 2.11.0 +from57 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , e3 + ) +from57 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , e3 + ) + +-- | @since 2.11.0 +to57 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , e3 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + ) +to57 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , e3 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + , RawSql e3 + , RawSql f3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + ) + where + rawSqlCols e = rawSqlCols e . from58 + rawSqlColCountReason = rawSqlColCountReason . from58 + rawSqlProcessRow = fmap to58 . rawSqlProcessRow + +-- | @since 2.11.0 +from58 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + ) +from58 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + ) + +-- | @since 2.11.0 +to58 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + ) +to58 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + , RawSql e3 + , RawSql f3 + , RawSql g3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + ) + where + rawSqlCols e = rawSqlCols e . from59 + rawSqlColCountReason = rawSqlColCountReason . from59 + rawSqlProcessRow = fmap to59 . rawSqlProcessRow + +-- | @since 2.11.0 +from59 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , g3 + ) +from59 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , g3 + ) + +-- | @since 2.11.0 +to59 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , g3 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + ) +to59 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , g3 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + , RawSql e3 + , RawSql f3 + , RawSql g3 + , RawSql h3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + ) + where + rawSqlCols e = rawSqlCols e . from60 + rawSqlColCountReason = rawSqlColCountReason . from60 + rawSqlProcessRow = fmap to60 . rawSqlProcessRow + +-- | @since 2.11.0 +from60 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + ) +from60 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + ) + +-- | @since 2.11.0 +to60 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + ) +to60 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + , RawSql e3 + , RawSql f3 + , RawSql g3 + , RawSql h3 + , RawSql i3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + ) + where + rawSqlCols e = rawSqlCols e . from61 + rawSqlColCountReason = rawSqlColCountReason . from61 + rawSqlProcessRow = fmap to61 . rawSqlProcessRow + +-- | @since 2.11.0 +from61 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , i3 + ) +from61 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , i3 + ) + +-- | @since 2.11.0 +to61 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , i3 + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + ) +to61 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , i3 + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + ) + +-- | @since 2.11.0 +instance + ( RawSql a + , RawSql b + , RawSql c + , RawSql d + , RawSql e + , RawSql f + , RawSql g + , RawSql h + , RawSql i + , RawSql j + , RawSql k + , RawSql l + , RawSql m + , RawSql n + , RawSql o + , RawSql p + , RawSql q + , RawSql r + , RawSql s + , RawSql t + , RawSql u + , RawSql v + , RawSql w + , RawSql x + , RawSql y + , RawSql z + , RawSql a2 + , RawSql b2 + , RawSql c2 + , RawSql d2 + , RawSql e2 + , RawSql f2 + , RawSql g2 + , RawSql h2 + , RawSql i2 + , RawSql j2 + , RawSql k2 + , RawSql l2 + , RawSql m2 + , RawSql n2 + , RawSql o2 + , RawSql p2 + , RawSql q2 + , RawSql r2 + , RawSql s2 + , RawSql t2 + , RawSql u2 + , RawSql v2 + , RawSql w2 + , RawSql x2 + , RawSql y2 + , RawSql z2 + , RawSql a3 + , RawSql b3 + , RawSql c3 + , RawSql d3 + , RawSql e3 + , RawSql f3 + , RawSql g3 + , RawSql h3 + , RawSql i3 + , RawSql j3 + ) + => RawSql + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + , j3 + ) + where + rawSqlCols e = rawSqlCols e . from62 + rawSqlColCountReason = rawSqlColCountReason . from62 + rawSqlProcessRow = fmap to62 . rawSqlProcessRow + +-- | @since 2.11.0 +from62 + :: ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + , j3 + ) + -> ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , (i3, j3) + ) +from62 + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + , j3 + ) = + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , (i3, j3) + ) + +-- | @since 2.11.0 +to62 + :: ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , (i3, j3) + ) + -> ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + , j3 + ) +to62 + ( (a, b) + , (c, d) + , (e, f) + , (g, h) + , (i, j) + , (k, l) + , (m, n) + , (o, p) + , (q, r) + , (s, t) + , (u, v) + , (w, x) + , (y, z) + , (a2, b2) + , (c2, d2) + , (e2, f2) + , (g2, h2) + , (i2, j2) + , (k2, l2) + , (m2, n2) + , (o2, p2) + , (q2, r2) + , (s2, t2) + , (u2, v2) + , (w2, x2) + , (y2, z2) + , (a3, b3) + , (c3, d3) + , (e3, f3) + , (g3, h3) + , (i3, j3) + ) = + ( a + , b + , c + , d + , e + , f + , g + , h + , i + , j + , k + , l + , m + , n + , o + , p + , q + , r + , s + , t + , u + , v + , w + , x + , y + , z + , a2 + , b2 + , c2 + , d2 + , e2 + , f2 + , g2 + , h2 + , i2 + , j2 + , k2 + , l2 + , m2 + , n2 + , o2 + , p2 + , q2 + , r2 + , s2 + , t2 + , u2 + , v2 + , w2 + , x2 + , y2 + , z2 + , a3 + , b3 + , c3 + , d3 + , e3 + , f3 + , g3 + , h3 + , i3 + , j3 + ) + +extractMaybe :: Maybe a -> a +extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe") + +-- | Tells Persistent what database column type should be used to store a Haskell type. +-- +-- ==== __Examples__ +-- +-- ===== Simple Boolean Alternative +-- +-- @ +-- data Switch = On | Off +-- deriving (Show, Eq) +-- +-- instance 'PersistField' Switch where +-- 'toPersistValue' s = case s of +-- On -> 'PersistBool' True +-- Off -> 'PersistBool' False +-- 'fromPersistValue' ('PersistBool' b) = if b then 'Right' On else 'Right' Off +-- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a Switch: expected PersistBool, received: " <> T.pack (show x) +-- +-- instance 'PersistFieldSql' Switch where +-- 'sqlType' _ = 'SqlBool' +-- @ +-- +-- ===== Non-Standard Database Types +-- +-- If your database supports non-standard types, such as Postgres' @uuid@, you can use 'SqlOther' to use them: +-- +-- @ +-- import qualified Data.UUID as UUID +-- instance 'PersistField' UUID where +-- 'toPersistValue' = 'PersistLiteralEncoded' . toASCIIBytes +-- 'fromPersistValue' ('PersistLiteralEncoded' uuid) = +-- case fromASCIIBytes uuid of +-- 'Nothing' -> 'Left' $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid) +-- 'Just' uuid' -> 'Right' uuid' +-- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistLiteralEncoded, received: "-- > <> T.pack (show x) +-- +-- instance 'PersistFieldSql' UUID where +-- 'sqlType' _ = 'SqlOther' "uuid" +-- @ +-- +-- ===== User Created Database Types +-- +-- Similarly, some databases support creating custom types, e.g. Postgres' and features. You can use 'SqlOther' to specify a custom type: +-- +-- > CREATE DOMAIN ssn AS text +-- > CHECK ( value ~ '^[0-9]{9}$'); +-- +-- @ +-- instance 'PersistFieldSQL' SSN where +-- 'sqlType' _ = 'SqlOther' "ssn" +-- @ +-- +-- > CREATE TYPE rainbow_color AS ENUM ('red', 'orange', 'yellow', 'green', 'blue', 'indigo', 'violet'); +-- +-- @ +-- instance 'PersistFieldSQL' RainbowColor where +-- 'sqlType' _ = 'SqlOther' "rainbow_color" +-- @ +class (PersistField a) => PersistFieldSql a where + sqlType :: Proxy a -> SqlType + +#ifndef NO_OVERLAP +instance {-# OVERLAPPING #-} PersistFieldSql [Char] where + sqlType _ = SqlString +#endif + +instance PersistFieldSql ByteString where + sqlType _ = SqlBlob +instance PersistFieldSql T.Text where + sqlType _ = SqlString +instance PersistFieldSql TL.Text where + sqlType _ = SqlString +instance PersistFieldSql Html where + sqlType _ = SqlString +instance PersistFieldSql Int where + sqlType _ + | Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32 + | otherwise = SqlInt64 +instance PersistFieldSql Int8 where + sqlType _ = SqlInt32 +instance PersistFieldSql Int16 where + sqlType _ = SqlInt32 +instance PersistFieldSql Int32 where + sqlType _ = SqlInt32 +instance PersistFieldSql Int64 where + sqlType _ = SqlInt64 +instance PersistFieldSql Word where + sqlType _ = SqlInt64 +instance PersistFieldSql Word8 where + sqlType _ = SqlInt32 +instance PersistFieldSql Word16 where + sqlType _ = SqlInt32 +instance PersistFieldSql Word32 where + sqlType _ = SqlInt64 +instance PersistFieldSql Word64 where + sqlType _ = SqlInt64 +instance PersistFieldSql Double where + sqlType _ = SqlReal +instance PersistFieldSql Bool where + sqlType _ = SqlBool +instance PersistFieldSql Day where + sqlType _ = SqlDay +instance PersistFieldSql TimeOfDay where + sqlType _ = SqlTime +instance PersistFieldSql UTCTime where + sqlType _ = SqlDayTime +instance (PersistFieldSql a) => PersistFieldSql (Maybe a) where + sqlType _ = sqlType (Proxy :: Proxy a) +instance {-# OVERLAPPABLE #-} (PersistFieldSql a) => PersistFieldSql [a] where + sqlType _ = SqlString +instance (PersistFieldSql a) => PersistFieldSql (V.Vector a) where + sqlType _ = SqlString +instance (Ord a, PersistFieldSql a) => PersistFieldSql (S.Set a) where + sqlType _ = SqlString +instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (a, b) where + sqlType _ = SqlString +instance (PersistFieldSql v) => PersistFieldSql (IM.IntMap v) where + sqlType _ = SqlString +instance (PersistFieldSql v) => PersistFieldSql (M.Map T.Text v) where + sqlType _ = SqlString +instance PersistFieldSql PersistValue where + sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64 +instance PersistFieldSql Checkmark where + sqlType _ = SqlBool +instance (HasResolution a) => PersistFieldSql (Fixed a) where + sqlType a = + SqlNumeric long prec + where + prec = round $ (log $ fromIntegral $ resolution n) / (log 10 :: Double) -- FIXME: May lead to problems with big numbers + long = prec + 10 -- FIXME: Is this enough ? + n = 0 + _mn = return n `asTypeOf` a + +instance PersistFieldSql Rational where + sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC + +-- | This type uses the 'SqlInt64' version, which will exhibit overflow and +-- underflow behavior. Additionally, it permits negative values in the +-- database, which isn't ideal. +-- +-- @since 2.11.0 +instance PersistFieldSql OverflowNatural where + sqlType _ = SqlInt64 -- An embedded Entity instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where diff --git a/Database/Persist/Sql/Internal.hs b/Database/Persist/Sql/Internal.hs --- a/Database/Persist/Sql/Internal.hs +++ b/Database/Persist/Sql/Internal.hs @@ -1,81 +1,230 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns , defaultAttribute + , BackendSpecificOverrides (..) + , getBackendSpecificForeignKeyName + , setBackendSpecificForeignKeyName + , getBackendSpecificForeignKeyCascadeDefault + , setBackendSpecificForeignKeyCascadeDefault + , emptyBackendSpecificOverrides ) where -import Data.Char (isSpace) +import Control.Applicative ((<|>)) import Data.Monoid (mappend, mconcat) import Data.Text (Text) import qualified Data.Text as T -import Database.Persist.Quasi +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Database.Persist.EntityDef import Database.Persist.Sql.Types import Database.Persist.Types -defaultAttribute :: [Attr] -> Maybe Text -defaultAttribute [] = Nothing -defaultAttribute (a:as) - | Just d <- T.stripPrefix "default=" a = Just d - | otherwise = defaultAttribute as +-- | Record of functions to override the default behavior in 'mkColumns'. It is +-- recommended you initialize this with 'emptyBackendSpecificOverrides' and +-- override the default values, so that as new fields are added, your code still +-- compiles. +-- +-- For added safety, use the @getBackendSpecific*@ and @setBackendSpecific*@ +-- functions, as a breaking change to the record field labels won't be reflected +-- in a major version bump of the library. +-- +-- @since 2.11 +data BackendSpecificOverrides = BackendSpecificOverrides + { backendSpecificForeignKeyName + :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) + , backendSpecificForeignKeyCascadeDefault :: CascadeAction + } +-- | If the override is defined, then this returns a function that accepts an +-- entity name and field name and provides the 'ConstraintNameDB' for the +-- foreign key constraint. +-- +-- An abstract accessor for the 'BackendSpecificOverrides' +-- +-- @since 2.13.0.0 +getBackendSpecificForeignKeyName + :: BackendSpecificOverrides + -> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) +getBackendSpecificForeignKeyName = + backendSpecificForeignKeyName + +-- | Set the backend's foreign key generation function to this value. +-- +-- @since 2.13.0.0 +setBackendSpecificForeignKeyName + :: (EntityNameDB -> FieldNameDB -> ConstraintNameDB) + -> BackendSpecificOverrides + -> BackendSpecificOverrides +setBackendSpecificForeignKeyName func bso = + bso{backendSpecificForeignKeyName = Just func} + +-- | If the override is defined, then this specifies what cascade action +-- should be used if there is none defined for the column. +-- +-- @since 2.18.1.0 +getBackendSpecificForeignKeyCascadeDefault + :: BackendSpecificOverrides + -> CascadeAction +getBackendSpecificForeignKeyCascadeDefault = + backendSpecificForeignKeyCascadeDefault + +-- | Set the backend's default cascade action. +-- +-- @since 2.18.1.0 +setBackendSpecificForeignKeyCascadeDefault + :: CascadeAction + -> BackendSpecificOverrides + -> BackendSpecificOverrides +setBackendSpecificForeignKeyCascadeDefault action bso = + bso{backendSpecificForeignKeyCascadeDefault = action} + +findMaybe :: (a -> Maybe b) -> [a] -> Maybe b +findMaybe p = listToMaybe . mapMaybe p + +-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides) +-- +-- @since 2.11 +emptyBackendSpecificOverrides :: BackendSpecificOverrides +emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing Restrict + +defaultAttribute :: [FieldAttr] -> Maybe Text +defaultAttribute = findMaybe $ \case + FieldAttrDefault x -> Just x + _ -> Nothing + -- | Create the list of columns for the given entity. -mkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -mkColumns allDefs t = - (cols, entityUniques t, entityForeigns t) +mkColumns + :: [EntityDef] + -> EntityDef + -> BackendSpecificOverrides + -> ([Column], [UniqueDef], [ForeignDef]) +mkColumns allDefs t overrides = + (cols, getEntityUniquesNoPrimaryKey t, getEntityForeignDefs t) where cols :: [Column] - cols = map go (entityFields t) + cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t) - tn :: DBName - tn = entityDB t + idCol :: [FieldDef] + idCol = + case getEntityId t of + EntityIdNaturalKey _ -> + [] + EntityIdField fd -> + [fd] + goId :: FieldDef -> Column + goId fd = + Column + { cName = fieldDB fd + , cNull = False + , cSqlType = fieldSqlType fd + , cDefault = + case defaultAttribute $ fieldAttrs fd of + Nothing -> + -- So this is not necessarily a problem... + -- because you can use eg `inserKey` to insert + -- a value into the database without ever asking + -- for a default attribute. + Nothing + -- But we need to be able to say "Hey, if this is + -- an *auto generated ID column*, then I need to + -- specify that it has the default serial picking + -- behavior for whatever SQL backend this is using. + -- Because naturally MySQL, Postgres, MSSQL, etc + -- all do ths differently, sigh. + -- Really, this should be something like, + -- + -- > data ColumnDefault + -- > = Custom Text + -- > | AutogenerateId + -- > | NoDefault + -- + -- where Autogenerated is determined by the + -- MkPersistSettings. + Just def -> + Just def + , cGenerated = fieldGenerated fd + , cDefaultConstraintName = Nothing + , cMaxLen = maxLen $ fieldAttrs fd + , cReference = mkColumnReference fd + } + + tableName :: EntityNameDB + tableName = getEntityDBName t + go :: FieldDef -> Column go fd = Column - (fieldDB fd) - (nullable (fieldAttrs fd) /= NotNullable || entitySum t) - (fieldSqlType fd) - (defaultAttribute $ fieldAttrs fd) - Nothing - (maxLen $ fieldAttrs fd) - (ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd)) + { cName = fieldDB fd + , cNull = + case isFieldNullable fd of + Nullable _ -> True + NotNullable -> isFieldMaybe fd || isEntitySum t + , cSqlType = fieldSqlType fd + , cDefault = defaultAttribute $ fieldAttrs fd + , cGenerated = fieldGenerated fd + , cDefaultConstraintName = Nothing + , cMaxLen = maxLen $ fieldAttrs fd + , cReference = mkColumnReference fd + } - maxLen :: [Attr] -> Maybe Integer - maxLen [] = Nothing - maxLen (a:as) - | Just d <- T.stripPrefix "maxlen=" a = - case reads (T.unpack d) of - [(i, s)] | all isSpace s -> Just i - _ -> error $ "Could not parse maxlen field with value " ++ - show d ++ " on " ++ show tn - | otherwise = maxLen as + maxLen :: [FieldAttr] -> Maybe Integer + maxLen = findMaybe $ \case + FieldAttrMaxlen n -> Just n + _ -> Nothing - ref :: DBName + refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides) + + mkColumnReference :: FieldDef -> Maybe ColumnReference + mkColumnReference fd = + fmap + ( \(tName, cName) -> + ColumnReference tName cName $ overrideNothings $ fieldCascade fd + ) + $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) + + -- a 'Nothing' in the definition means that the QQ migration doesn't + -- specify behavior. the default is RESTRICT. setting this here + -- explicitly makes migrations run smoother. + overrideNothings (FieldCascade{fcOnUpdate = upd, fcOnDelete = del}) = + FieldCascade + { fcOnUpdate = upd <|> Just defaultAction + , fcOnDelete = del <|> Just defaultAction + } + where + defaultAction = (backendSpecificForeignKeyCascadeDefault overrides) + + ref + :: FieldNameDB -> ReferenceDef - -> [Attr] - -> Maybe (DBName, DBName) -- table name, constraint name + -> [FieldAttr] + -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name ref c fe [] - | ForeignRef f _ <- fe = - Just (resolveTableName allDefs f, refName tn c) + | ForeignRef f <- fe = + Just (resolveTableName allDefs f, refNameFn tableName c) | otherwise = Nothing - ref _ _ ("noreference":_) = Nothing - ref c fe (a:as) - | Just x <- T.stripPrefix "reference=" a = do - constraintName <- snd <$> (ref c fe as) - pure (DBName x, constraintName) - | Just x <- T.stripPrefix "constraint=" a = do - tableName <- fst <$> (ref c fe as) - pure (tableName, DBName x) - ref c x (_:as) = ref c x as + ref _ _ (FieldAttrNoreference : _) = Nothing + ref c fe (a : as) = case a of + FieldAttrReference x -> do + (_, constraintName) <- ref c fe as + pure (EntityNameDB x, constraintName) + FieldAttrConstraint x -> do + (tableName_, _) <- ref c fe as + pure (tableName_, ConstraintNameDB x) + _ -> ref c fe as -refName :: DBName -> DBName -> DBName -refName (DBName table) (DBName column) = - DBName $ Data.Monoid.mconcat [table, "_", column, "_fkey"] +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + ConstraintNameDB $ Data.Monoid.mconcat [table, "_", column, "_fkey"] -resolveTableName :: [EntityDef] -> HaskellName -> DBName -resolveTableName [] (HaskellName hn) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack hn -resolveTableName (e:es) hn - | entityHaskell e == hn = entityDB e +resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB +resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t +resolveTableName (e : es) hn + | getEntityHaskellName e == hn = getEntityDBName e | otherwise = resolveTableName es hn diff --git a/Database/Persist/Sql/Migration.hs b/Database/Persist/Sql/Migration.hs --- a/Database/Persist/Sql/Migration.hs +++ b/Database/Persist/Sql/Migration.hs @@ -1,47 +1,111 @@ +-- | This module documents tools and utilities for running SQL migrations. +-- +-- A 'Migration' is (currently) an alias for a 'WriterT' of module Database.Persist.Sql.Migration - ( parseMigration - , parseMigration' - , printMigration - , showMigration - , getMigration - , runMigration - , runMigrationQuiet - , runMigrationSilent - , runMigrationUnsafe - , runMigrationUnsafeQuiet - , migrate - -- * Utilities for constructing migrations - , reportErrors - , reportError - , addMigrations - , addMigration - ) where + ( -- * Types + Migration + , CautiousMigration + , Sql + -- * Using a 'Migration' + , showMigration + , parseMigration + , parseMigration' + , printMigration + , getMigration + , runMigration + , runMigrationQuiet + , runMigrationSilent + , runMigrationUnsafe + , runMigrationUnsafeQuiet + , migrate + -- * Utilities for constructing migrations + + -- | While 'migrate' is capable of creating a 'Migration' for you, it's not + -- the only way you can write migrations. You can use these utilities to write + -- extra steps in your migrations. + -- + -- As an example, let's say we want to enable the @citext@ extension on + -- @postgres@ as part of our migrations. + -- + -- @ + -- 'Database.Persist.TH.share' ['Database.Persist.TH.mkPersist' sqlSettings, 'Database.Persist.TH.mkMigration' "migrateAll"] ... + -- + -- migration :: 'Migration' + -- migration = do + -- 'runSqlCommand' $ + -- 'rawExecute_' "CREATE EXTENSION IF NOT EXISTS \"citext\";" + -- migrateAll + -- @ + -- + -- For raw commands, you can also just write 'addMigration': + -- + -- @ + -- migration :: 'Migration' + -- migration = do + -- 'addMigration' "CREATE EXTENSION IF NOT EXISTS \"citext\";" + -- migrateAll + -- @ + , reportErrors + , reportError + , addMigrations + , addMigration + , runSqlCommand + + -- * If something goes wrong... + , PersistUnsafeMigrationException (..) + ) where + import Control.Exception (throwIO) import Control.Monad (liftM, unless) import Control.Monad.IO.Unlift import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.Trans.Reader (ReaderT (..), ask) import Control.Monad.Trans.Writer -import Data.Text (Text, unpack, snoc, isPrefixOf, pack) +import Data.Text (Text, isPrefixOf, pack, snoc, unpack) import qualified Data.Text.IO +import GHC.Stack import System.IO import System.IO.Silently (hSilence) -import Database.Persist.Sql.Types +import Control.Exception (Exception (..)) +import Database.Persist.Sql.Orphan.PersistStore () import Database.Persist.Sql.Raw +import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal import Database.Persist.Types -import Database.Persist.Sql.Orphan.PersistStore() +type Sql = Text + +-- | A list of SQL operations, marked with a safety flag. If the 'Bool' is +-- 'True', then the operation is *unsafe* - it might be destructive, or +-- otherwise not idempotent. If the 'Bool' is 'False', then the operation +-- is *safe*, and can be run repeatedly without issues. +type CautiousMigration = [(Bool, Sql)] + +-- | A 'Migration' is a four level monad stack consisting of: +-- +-- * @'WriterT' ['Text']@ representing a log of errors in the migrations. +-- * @'WriterT' 'CautiousMigration'@ representing a list of migrations to +-- run, along with whether or not they are safe. +-- * @'ReaderT' 'SqlBackend'@, aka the 'SqlPersistT' transformer for +-- database interop. +-- * @'IO'@ for arbitrary IO. +type Migration = + WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) () + allSql :: CautiousMigration -> [Sql] allSql = map snd + safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) -- | Given a 'Migration', this parses it and returns either a list of -- errors associated with the migration or a list of migrations to do. -parseMigration :: MonadIO m => Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration) +parseMigration + :: (HasCallStack, MonadIO m) + => Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration) parseMigration = liftIOReader . liftM go . runWriterT . execWriterT where @@ -52,35 +116,41 @@ -- | Like 'parseMigration', but instead of returning the value in an -- 'Either' value, it calls 'error' on the error values. -parseMigration' :: MonadIO m => Migration -> ReaderT SqlBackend m (CautiousMigration) +parseMigration' + :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m CautiousMigration parseMigration' m = do - x <- parseMigration m - case x of - Left errs -> error $ unlines $ map unpack errs - Right sql -> return sql + x <- parseMigration m + case x of + Left errs -> error $ unlines $ map unpack errs + Right sql -> return sql -- | Prints a migration. -printMigration :: MonadIO m => Migration -> ReaderT SqlBackend m () -printMigration m = showMigration m - >>= mapM_ (liftIO . Data.Text.IO.putStrLn) +printMigration + :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m () +printMigration m = + showMigration m + >>= mapM_ (liftIO . Data.Text.IO.putStrLn) -- | Convert a 'Migration' to a list of 'Text' values corresponding to their -- 'Sql' statements. -showMigration :: MonadIO m => Migration -> ReaderT SqlBackend m [Text] +showMigration + :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m [Text] showMigration m = map (flip snoc ';') `liftM` getMigration m -- | Return all of the 'Sql' values associated with the given migration. -- Calls 'error' if there's a parse error on any migration. -getMigration :: MonadIO m => Migration -> ReaderT SqlBackend m [Sql] +getMigration + :: (MonadIO m, HasCallStack) => Migration -> ReaderT SqlBackend m [Sql] getMigration m = do - mig <- parseMigration' m - return $ allSql mig + mig <- parseMigration' m + return $ allSql mig -- | Runs a migration. If the migration fails to parse or if any of the --- migrations are unsafe, then this calls 'error' to halt the program. -runMigration :: MonadIO m - => Migration - -> ReaderT SqlBackend m () +-- migrations are unsafe, then this throws a 'PersistUnsafeMigrationException'. +runMigration + :: (MonadIO m) + => Migration + -> ReaderT SqlBackend m () runMigration m = runMigration' m False >> return () -- | Same as 'runMigration', but does not report the individual migrations on @@ -91,9 +161,10 @@ -- persistent-postgresql -- -- @since 2.10.2 -runMigrationQuiet :: MonadIO m - => Migration - -> ReaderT SqlBackend m [Text] +runMigrationQuiet + :: (MonadIO m) + => Migration + -> ReaderT SqlBackend m [Text] runMigrationQuiet m = runMigration' m True -- | Same as 'runMigration', but returns a list of the SQL commands executed @@ -103,59 +174,56 @@ -- is not thread-safe and can clobber output from other parts of the program. -- This implementation method was chosen to also silence postgresql migration -- output on stderr, but is not recommended! -runMigrationSilent :: MonadUnliftIO m - => Migration - -> ReaderT SqlBackend m [Text] +runMigrationSilent + :: (MonadUnliftIO m) + => Migration + -> ReaderT SqlBackend m [Text] runMigrationSilent m = withRunInIO $ \run -> - hSilence [stderr] $ run $ runMigration' m True + hSilence [stderr] $ run $ runMigration' m True -- | Run the given migration against the database. If the migration fails -- to parse, or there are any unsafe migrations, then this will error at -- runtime. This returns a list of the migrations that were executed. runMigration' - :: MonadIO m + :: (HasCallStack, MonadIO m) => Migration - -> Bool -- ^ is silent? + -> Bool + -- ^ is silent? -> ReaderT SqlBackend m [Text] runMigration' m silent = do mig <- parseMigration' m if any fst mig - then liftIO . throwIO . PersistError . pack $ concat - [ "\n\nDatabase migration: manual intervention required.\n" - , "The unsafe actions are prefixed by '***' below:\n\n" - , unlines $ map displayMigration mig - ] + then liftIO . throwIO $ PersistUnsafeMigrationException mig else mapM (executeMigrate silent) $ sortMigrations $ safeSql mig - where - displayMigration :: (Bool, Sql) -> String - displayMigration (True, s) = "*** " ++ unpack s ++ ";" - displayMigration (False, s) = " " ++ unpack s ++ ";" -- | Like 'runMigration', but this will perform the unsafe database -- migrations instead of erroring out. -runMigrationUnsafe :: MonadIO m - => Migration - -> ReaderT SqlBackend m () +runMigrationUnsafe + :: (MonadIO m) + => Migration + -> ReaderT SqlBackend m () runMigrationUnsafe m = runMigrationUnsafe' False m >> return () -- | Same as 'runMigrationUnsafe', but returns a list of the SQL commands -- executed instead of printing them to stderr. -- -- @since 2.10.2 -runMigrationUnsafeQuiet :: MonadIO m - => Migration - -> ReaderT SqlBackend m [Text] +runMigrationUnsafeQuiet + :: (HasCallStack, MonadIO m) + => Migration + -> ReaderT SqlBackend m [Text] runMigrationUnsafeQuiet = runMigrationUnsafe' True -runMigrationUnsafe' :: MonadIO m - => Bool - -> Migration - -> ReaderT SqlBackend m [Text] +runMigrationUnsafe' + :: (HasCallStack, MonadIO m) + => Bool + -> Migration + -> ReaderT SqlBackend m [Text] runMigrationUnsafe' silent m = do mig <- parseMigration' m mapM (executeMigrate silent) $ sortMigrations $ allSql mig -executeMigrate :: MonadIO m => Bool -> Text -> ReaderT SqlBackend m Text +executeMigrate :: (MonadIO m) => Bool -> Text -> ReaderT SqlBackend m Text executeMigrate silent s = do unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s rawExecute s [] @@ -174,9 +242,10 @@ -- | Given a list of old entity definitions and a new 'EntityDef' in -- @val@, this creates a 'Migration' to update the old list of definitions -- with the new one. -migrate :: [EntityDef] - -> EntityDef - -> Migration +migrate + :: [EntityDef] + -> EntityDef + -> Migration migrate allDefs val = do conn <- lift $ lift ask res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val @@ -199,12 +268,14 @@ -- @since 2.9.2 addMigration :: Bool - -- ^ Is the migration safe to run? (eg a non-destructive and idempotent - -- update on the schema) + -- ^ Is the migration unsafe to run? (eg a destructive or non-idempotent + -- update on the schema). If 'True', the migration is *unsafe*, and will + -- need to be run manually later. If 'False', the migration is *safe*, and + -- can be run any number of times. -> Sql -- ^ A 'Text' value representing the command to run on the database. -> Migration -addMigration isSafe sql = lift (tell [(isSafe, sql)]) +addMigration isUnsafe sql = lift (tell [(isUnsafe, sql)]) -- | Add a 'CautiousMigration' (aka a @[('Bool', 'Text')]@) to the -- migration plan. @@ -214,3 +285,40 @@ :: CautiousMigration -> Migration addMigrations = lift . tell + +-- | Run an action against the database during a migration. Can be useful for eg +-- creating Postgres extensions: +-- +-- @ +-- runSqlCommand $ 'rawExecute' "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" [] +-- @ +-- +-- @since 2.13.0.0 +runSqlCommand :: SqlPersistT IO () -> Migration +runSqlCommand = lift . lift + +-- | An exception indicating that Persistent refused to run some unsafe +-- migrations. Contains a list of pairs where the Bool tracks whether the +-- migration was unsafe (True means unsafe), and the Sql is the sql statement +-- for the migration. +-- +-- @since 2.11.1.0 +newtype PersistUnsafeMigrationException + = PersistUnsafeMigrationException [(Bool, Sql)] + +-- | This 'Show' instance renders an error message suitable for printing to the +-- console. This is a little dodgy, but since GHC uses Show instances when +-- displaying uncaught exceptions, we have little choice. +instance Show PersistUnsafeMigrationException where + show (PersistUnsafeMigrationException mig) = + concat + [ "\n\nDatabase migration: manual intervention required.\n" + , "The unsafe actions are prefixed by '***' below:\n\n" + , unlines $ map displayMigration mig + ] + where + displayMigration :: (Bool, Sql) -> String + displayMigration (True, s) = "*** " ++ unpack s ++ ";" + displayMigration (False, s) = " " ++ unpack s ++ ";" + +instance Exception PersistUnsafeMigrationException diff --git a/Database/Persist/Sql/Orphan/PersistQuery.hs b/Database/Persist/Sql/Orphan/PersistQuery.hs --- a/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -1,60 +1,105 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} - +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- | TODO: delete this module and get it in with SqlBackend.Internal module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount + , filterClause + , filterClauseHelper + , filterClauseWithVals + , orderClause + , FilterTablePrefix (..) , decorateSQLWithLimitOffset ) where import Control.Exception (throwIO) import Control.Monad.IO.Class -import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) +import Control.Monad.Trans.Reader (ReaderT, ask) import Data.ByteString.Char8 (readInteger) import Data.Conduit import qualified Data.Conduit.List as CL +import Data.Foldable (toList) import Data.Int (Int64) -import Data.List (transpose, inits, find) +import Data.List (find, inits, transpose) import Data.Maybe (isJust) -import Data.Monoid (Monoid (..), (<>)) -import qualified Data.Text as T +import Data.Monoid (Monoid (..)) import Data.Text (Text) +import qualified Data.Text as T import Database.Persist hiding (updateField) -import Database.Persist.Sql.Util ( - entityColumnNames, parseEntityValues, isIdField, updatePersistValue - , mkUpdateText, commaSeparated, dbIdColumns) -import Database.Persist.Sql.Types -import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Types.Internal + ( SqlBackend (..) + , SqlReadBackend + , SqlWriteBackend + ) +import Database.Persist.Sql.Util + ( commaSeparated + , dbIdColumns + , isIdField + , keyAndEntityColumnNames + , mkUpdateText + , parseEntityValues + , parseExistsResult + , updatePersistValue + ) -- orphaned instance for convenience of modularity instance PersistQueryRead SqlBackend where count filts = do conn <- ask - let wher = if null filts + let + wher = + if null filts then "" - else filterClause False conn filts - let sql = mconcat - [ "SELECT COUNT(*) FROM " - , connEscapeName conn $ entityDB t - , wher - ] + else filterClause Nothing conn filts + let + sql = + mconcat + [ "SELECT COUNT(*) FROM " + , connEscapeTableName conn t + , wher + ] withRawQuery sql (getFiltsValues conn filts) $ do mm <- CL.head case mm of - Just [PersistInt64 i] -> return $ fromIntegral i - Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle - Just [PersistByteString i] -> case readInteger i of -- gb mssql - Just (ret,"") -> return $ fromIntegral ret - xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" - Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]" - Nothing -> error $ "count:invalid sql returned nothing sql["++show sql++"]" + Just [PersistInt64 i] -> return $ fromIntegral i + Just [PersistDouble i] -> return $ fromIntegral (truncate i :: Int64) -- gb oracle + Just [PersistByteString i] -> case readInteger i of -- gb mssql + Just (ret, "") -> return $ fromIntegral ret + xs -> error $ "invalid number i[" ++ show i ++ "] xs[" ++ show xs ++ "]" + Just xs -> + error $ + "count:invalid sql return xs[" ++ show xs ++ "] sql[" ++ show sql ++ "]" + Nothing -> error $ "count:invalid sql returned nothing sql[" ++ show sql ++ "]" where t = entityDef $ dummyFromFilts filts + exists filts = do + conn <- ask + let + wher = + if null filts + then "" + else filterClause Nothing conn filts + let + sql = + mconcat + [ "SELECT EXISTS(SELECT 1 FROM " + , connEscapeTableName conn t + , wher + , ")" + ] + withRawQuery sql (getFiltsValues conn filts) $ do + mm <- CL.head + return $ parseExistsResult mm sql "PersistQuery.exists" + where + t = entityDef $ dummyFromFilts filts + selectSourceRes filts opts = do conn <- ask srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts) @@ -62,26 +107,32 @@ where (limit, offset, orders) = limitOffsetOrder opts - parse vals = case parseEntityValues t vals of - Left s -> liftIO $ throwIO $ PersistMarshalError s - Right row -> return row + parse vals = + case parseEntityValues t vals of + Left s -> + liftIO $ + throwIO $ + PersistMarshalError + ("selectSourceRes: " <> s <> ", vals: " <> T.pack (show vals)) + Right row -> + return row t = entityDef $ dummyFromFilts filts - wher conn = if null filts - then "" - else filterClause False conn filts - ord conn = - case map (orderClause False conn) orders of - [] -> "" - ords -> " ORDER BY " <> T.intercalate "," ords - cols = commaSeparated . entityColumnNames t - sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat - [ "SELECT " - , cols conn - , " FROM " - , connEscapeName conn $ entityDB t - , wher conn - , ord conn - ] + wher conn = + if null filts + then "" + else filterClause Nothing conn filts + ord conn = orderClause Nothing conn orders + cols = commaSeparated . toList . keyAndEntityColumnNames t + sql conn = + connLimitOffset conn (limit, offset) $ + mconcat + [ "SELECT " + , cols conn + , " FROM " + , connEscapeTableName conn t + , wher conn + , ord conn + ] selectKeysRes filts opts = do conn <- ask @@ -89,50 +140,56 @@ return $ fmap (.| CL.mapM parse) srcRes where t = entityDef $ dummyFromFilts filts - cols conn = T.intercalate "," $ dbIdColumns conn t - + cols conn = T.intercalate "," $ toList $ dbIdColumns conn t - wher conn = if null filts - then "" - else filterClause False conn filts - sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat - [ "SELECT " - , cols conn - , " FROM " - , connEscapeName conn $ entityDB t - , wher conn - , ord conn - ] + wher conn = + if null filts + then "" + else filterClause Nothing conn filts + sql conn = + connLimitOffset conn (limit, offset) $ + mconcat + [ "SELECT " + , cols conn + , " FROM " + , connEscapeTableName conn t + , wher conn + , ord conn + ] (limit, offset, orders) = limitOffsetOrder opts - ord conn = - case map (orderClause False conn) orders of - [] -> "" - ords -> " ORDER BY " <> T.intercalate "," ords + ord conn = orderClause Nothing conn orders parse xs = do keyvals <- case entityPrimary t of - Nothing -> - case xs of - [PersistInt64 x] -> return [PersistInt64 x] - [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double - _ -> return xs - Just pdef -> - let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs - in return keyvals + Nothing -> + case xs of + [PersistInt64 x] -> return [PersistInt64 x] + [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double + _ -> return xs + Just pdef -> + let + pks = map fieldHaskell $ toList $ compositeFields pdef + keyvals = + map snd $ + filter (\(a, _) -> let ret = isJust (find (== a) pks) in ret) $ + zip (map fieldHaskell $ getEntityFields t) xs + in + return keyvals case keyFromValues keyvals of Right k -> return k Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err instance PersistQueryRead SqlReadBackend where - count filts = withReaderT persistBackend $ count filts - selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts - selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts + count filts = withBaseBackend $ count filts + exists filts = withBaseBackend $ exists filts + selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts + selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts instance PersistQueryRead SqlWriteBackend where - count filts = withReaderT persistBackend $ count filts - selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts - selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts + count filts = withBaseBackend $ count filts + exists filts = withBaseBackend $ exists filts + selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts + selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts instance PersistQueryWrite SqlBackend where deleteWhere filts = do @@ -142,77 +199,134 @@ _ <- updateWhereCount filts upds return () instance PersistQueryWrite SqlWriteBackend where - deleteWhere filts = withReaderT persistBackend $ deleteWhere filts - updateWhere filts upds = withReaderT persistBackend $ updateWhere filts upds + deleteWhere filts = withBaseBackend $ deleteWhere filts + updateWhere filts upds = withBaseBackend $ updateWhere filts upds -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- @since 1.1.5 -deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, BackendCompatible SqlBackend backend) - => [Filter val] - -> ReaderT backend m Int64 -deleteWhereCount filts = withReaderT projectBackend $ do +deleteWhereCount + :: ( PersistEntity val + , MonadIO m + , PersistEntityBackend val ~ SqlBackend + , BackendCompatible SqlBackend backend + ) + => [Filter val] + -> ReaderT backend m Int64 +deleteWhereCount filts = withCompatibleBackend $ do conn <- ask - let t = entityDef $ dummyFromFilts filts - let wher = if null filts + let + t = entityDef $ dummyFromFilts filts + let + wher = + if null filts then "" - else filterClause False conn filts - sql = mconcat - [ "DELETE FROM " - , connEscapeName conn $ entityDB t - , wher - ] + else filterClause Nothing conn filts + sql = + mconcat + [ "DELETE FROM " + , connEscapeTableName conn t + , wher + ] rawExecuteCount sql $ getFiltsValues conn filts -- | Same as 'updateWhere', but returns the number of rows affected. -- -- @since 1.1.5 -updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, BackendCompatible SqlBackend backend) - => [Filter val] - -> [Update val] - -> ReaderT backend m Int64 +updateWhereCount + :: ( PersistEntity val + , MonadIO m + , SqlBackend ~ PersistEntityBackend val + , BackendCompatible SqlBackend backend + ) + => [Filter val] + -> [Update val] + -> ReaderT backend m Int64 updateWhereCount _ [] = return 0 -updateWhereCount filts upds = withReaderT projectBackend $ do +updateWhereCount filts upds = withCompatibleBackend $ do conn <- ask - let wher = if null filts + let + wher = + if null filts then "" - else filterClause False conn filts - let sql = mconcat - [ "UPDATE " - , connEscapeName conn $ entityDB t - , " SET " - , T.intercalate "," $ map (mkUpdateText conn) upds - , wher - ] - let dat = map updatePersistValue upds `Data.Monoid.mappend` - getFiltsValues conn filts + else filterClause Nothing conn filts + let + sql = + mconcat + [ "UPDATE " + , connEscapeTableName conn t + , " SET " + , T.intercalate "," $ map (mkUpdateText conn) upds + , wher + ] + let + dat = + map updatePersistValue upds + `Data.Monoid.mappend` getFiltsValues conn filts rawExecuteCount sql dat where t = entityDef $ dummyFromFilts filts -fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> DBName +fieldName + :: forall record typ + . (PersistEntity record) => EntityField record typ -> FieldNameDB fieldName f = fieldDB $ persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing -getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => SqlBackend -> [Filter val] -> [PersistValue] -getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo +getFiltsValues + :: forall val + . (PersistEntity val) + => SqlBackend -> [Filter val] -> [PersistValue] +getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo -filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> Bool -- ^ include WHERE? - -> SqlBackend - -> OrNull - -> [Filter val] - -> (Text, [PersistValue]) -filterClauseHelper includeTable includeWhere conn orNull filters = - (if not (T.null sql) && includeWhere +-- | Used when determining how to prefix a column name in a @WHERE@ clause. +-- +-- @since 2.12.1.0 +data FilterTablePrefix + = -- | Prefix the column with the table name. This is useful if the column + -- name might be ambiguous. + -- + -- @since 2.12.1.0 + PrefixTableName + | -- | Prefix the column name with the @EXCLUDED@ keyword. This is used with + -- the Postgresql backend when doing @ON CONFLICT DO UPDATE@ clauses - see + -- the documentation on @upsertWhere@ and @upsertManyWhere@. + -- + -- @since 2.12.1.0 + PrefixExcluded + +prefixByTable + :: Maybe FilterTablePrefix + -> Text + -- ^ Table name + -> (Text -> Text) + -- ^ Prefixing function +prefixByTable tablePrefix tableName = + case tablePrefix of + Just PrefixTableName -> ((tableName <> ".") <>) + Just PrefixExcluded -> (("EXCLUDED.") <>) + _ -> id + +filterClauseHelper + :: (PersistEntity val) + => Maybe FilterTablePrefix + -- ^ include table name or PostgresSQL EXCLUDED + -> Bool + -- ^ include WHERE + -> SqlBackend + -> OrNull + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseHelper tablePrefix includeWhere conn orNull filters = + ( if not (T.null sql) && includeWhere then " WHERE " <> sql - else sql, vals) + else sql + , vals + ) where (sql, vals) = combineAND filters combineAND = combine " AND " @@ -227,101 +341,186 @@ go (FilterAnd []) = ("1=1", []) go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) - go (FilterOr fs) = combine " OR " fs + go (FilterOr fs) = combine " OR " fs go (Filter field value pfilter) = - let t = entityDef $ dummyFromFilts [Filter field value pfilter] - in case (isIdField field, entityPrimary t, allVals) of - (True, Just pdef, PersistList ys:_) -> - if length (compositeFields pdef) /= length ys - then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals - else - case (allVals, pfilter, isCompFilter pfilter) of - ([PersistList xs], Eq, _) -> - let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) - in (wrapSql sqlcl,xs) - ([PersistList xs], Ne, _) -> - let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) - in (wrapSql sqlcl,xs) - (_, In, _) -> - let xxs = transpose (map fromPersistList allVals) - sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) - in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) - (_, NotIn, _) -> - let xxs = transpose (map fromPersistList allVals) - sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) - in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) - ([PersistList xs], _, True) -> - let zs = tail (inits (compositeFields pdef)) - sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs - sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " - sqlcl = T.intercalate " or " sql1 - in (wrapSql sqlcl, concat (tail (inits xs))) - (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" - _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals - (True, Just pdef, []) -> - error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef - (True, Just pdef, _) -> - error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef - - _ -> case (isNull, pfilter, length notNullVals) of - (True, Eq, _) -> (name <> " IS NULL", []) - (True, Ne, _) -> (name <> " IS NOT NULL", []) - (False, Ne, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " <> " - , qmarks - , ")" - ], notNullVals) - -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since - -- not all databases support those words directly. - (_, In, 0) -> ("1=2" <> orNullSuffix, []) - (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) - (True, In, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " IN " - , qmarks - , ")" - ], notNullVals) - (False, NotIn, 0) -> ("1=1", []) - (True, NotIn, 0) -> (name <> " IS NOT NULL", []) - (False, NotIn, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - (True, NotIn, _) -> (T.concat - [ "(" - , name - , " IS NOT NULL AND " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) - + let + t = entityDef $ dummyFromFilts [Filter field value pfilter] + in + case (isIdField field, entityPrimary t, allVals) of + (True, Just pdef, PersistList ys : _) -> + let + cfields = toList $ compositeFields pdef + in + if length cfields /= length ys + then + error $ + "wrong number of entries in compositeFields vs PersistList allVals=" + ++ show allVals + else case (allVals, pfilter, isCompFilter pfilter) of + ([PersistList xs], Eq, _) -> + let + sqlcl = + T.intercalate + " and " + ( map + (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") + cfields + ) + in + (wrapSql sqlcl, xs) + ([PersistList xs], Ne, _) -> + let + sqlcl = + T.intercalate + " or " + ( map + (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") + cfields + ) + in + (wrapSql sqlcl, xs) + (_, In, _) -> + let + xxs = transpose (map fromPersistList allVals) + sqls = + map + ( \(a, xs) -> + connEscapeFieldName conn (fieldDB a) + <> showSqlFilter pfilter + <> "(" + <> T.intercalate "," (replicate (length xs) " ?") + <> ") " + ) + (zip cfields xxs) + in + (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) + (_, NotIn, _) -> + let + xxs = transpose (map fromPersistList allVals) + sqls = + map + ( \(a, xs) -> + connEscapeFieldName conn (fieldDB a) + <> showSqlFilter pfilter + <> "(" + <> T.intercalate "," (replicate (length xs) " ?") + <> ") " + ) + (zip cfields xxs) + in + (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) + ([PersistList xs], _, True) -> + let + zs = tail (inits (toList $ compositeFields pdef)) + sql1 = + map + ( \b -> + wrapSql + (T.intercalate " and " (map (\(i, a) -> sql2 (i == length b) a) (zip [1 ..] b))) + ) + zs + sql2 islast a = + connEscapeFieldName conn (fieldDB a) + <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) + <> "? " + sqlcl = T.intercalate " or " sql1 + in + (wrapSql sqlcl, concat (tail (inits xs))) + (_, BackendSpecificFilter _, _) -> + error "unhandled type BackendSpecificFilter for composite/non id primary keys" + _ -> + error $ + "unhandled type/filter for composite/non id primary keys pfilter=" + ++ show pfilter + ++ " persistList=" + ++ show allVals + (True, Just pdef, []) -> + error $ + "empty list given as filter value filter=" + ++ show pfilter + ++ " persistList=" + ++ show allVals + ++ " pdef=" + ++ show pdef + (True, Just pdef, _) -> + error $ + "unhandled error for composite/non id primary keys filter=" + ++ show pfilter + ++ " persistList=" + ++ show allVals + ++ " pdef=" + ++ show pdef + _ -> case (isNull, pfilter, length notNullVals) of + (True, Eq, _) -> (name <> " IS NULL", []) + (True, Ne, _) -> (name <> " IS NOT NULL", []) + (False, Ne, _) -> + ( T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " <> " + , qmarks + , ")" + ] + , notNullVals + ) + -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since + -- not all databases support those words directly. + (_, In, 0) -> ("1=2" <> orNullSuffix, []) + (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) + (True, In, _) -> + ( T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " IN " + , qmarks + , ")" + ] + , notNullVals + ) + (False, NotIn, 0) -> ("1=1", []) + (True, NotIn, 0) -> (name <> " IS NOT NULL", []) + (False, NotIn, _) -> + ( T.concat + [ "(" + , name + , " IS NULL OR " + , name + , " NOT IN " + , qmarks + , ")" + ] + , notNullVals + ) + (True, NotIn, _) -> + ( T.concat + [ "(" + , name + , " IS NOT NULL AND " + , name + , " NOT IN " + , qmarks + , ")" + ] + , notNullVals + ) + _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where isCompFilter Lt = True isCompFilter Le = True isCompFilter Gt = True isCompFilter Ge = True - isCompFilter _ = False + isCompFilter _ = False wrapSql sqlcl = "(" <> sqlcl <> ")" fromPersistList (PersistList xs) = xs fromPersistList other = error $ "expected PersistList but found " ++ show other - filterValueToPersistValues :: forall a. PersistField a => FilterValue a -> [PersistValue] + filterValueToPersistValues + :: forall a. (PersistField a) => FilterValue a -> [PersistValue] filterValueToPersistValues = \case FilterValue a -> [toPersistValue a] FilterValues as -> toPersistValue <$> as @@ -329,28 +528,33 @@ orNullSuffix = case orNull of - OrNullYes -> mconcat [" OR ", name, " IS NULL"] + OrNullYes -> + mconcat + [ " OR " + , name + , " IS NULL" + ] OrNullNo -> "" isNull = PersistNull `elem` allVals notNullVals = filter (/= PersistNull) allVals allVals = filterValueToPersistValues value - tn = connEscapeName conn $ entityDB - $ entityDef $ dummyFromFilts [Filter field value pfilter] - name = - (if includeTable - then ((tn <> ".") <>) - else id) - $ connEscapeName conn $ fieldName field + tn = + connEscapeTableName conn $ + entityDef $ + dummyFromFilts [Filter field value pfilter] + name = prefixByTable tablePrefix tn $ connEscapeFieldName conn (fieldName field) qmarks = case value of - FilterValue{} -> "(?)" - UnsafeValue{} -> "(?)" - FilterValues xs -> - let parens a = "(" <> a <> ")" - commas = T.intercalate "," - toQs = fmap $ const "?" - nonNulls = filter (/= PersistNull) $ map toPersistValue xs - in parens . commas . toQs $ nonNulls + FilterValue{} -> "(?)" + UnsafeValue{} -> "(?)" + FilterValues xs -> + let + parens a = "(" <> a <> ")" + commas = T.intercalate "," + toQs = fmap $ const "?" + nonNulls = filter (/= PersistNull) $ map toPersistValue xs + in + parens . commas . toQs $ nonNulls showSqlFilter Eq = "=" showSqlFilter Ne = "<>" showSqlFilter Gt = ">" @@ -361,49 +565,90 @@ showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s -filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> SqlBackend - -> [Filter val] - -> Text +-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion +-- into a SQL query. +-- +-- @since 2.12.1.0 +filterClause + :: (PersistEntity val) + => Maybe FilterTablePrefix + -- ^ include table name or EXCLUDED + -> SqlBackend + -> [Filter val] + -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include the table name - -> SqlBackend - -> SelectOpt val - -> Text -orderClause includeTable conn o = - case o of - Asc x -> name x - Desc x -> name x <> " DESC" - _ -> error "orderClause: expected Asc or Desc, not limit or offset" +-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion +-- into a SQL query, as well as the @['PersistValue']@ to properly fill in the +-- @?@ place holders. +-- +-- @since 2.12.1.0 +filterClauseWithVals + :: (PersistEntity val) + => Maybe FilterTablePrefix + -- ^ include table name or EXCLUDED + -> SqlBackend + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseWithVals b c = filterClauseHelper b True c OrNullNo + +-- | Render a @['SelectOpt' record]@ made up *only* of 'Asc' and 'Desc' constructors +-- into a 'Text' value suitable for inclusion into a SQL query. +-- +-- @since 2.13.2.0 +orderClause + :: (PersistEntity val) + => Maybe FilterTablePrefix + -- ^ include table name or EXCLUDED + -> SqlBackend + -> [SelectOpt val] + -> Text +orderClause includeTable conn orders = + if null orders + then "" + else + " ORDER BY " + <> T.intercalate + "," + ( map + ( \case + Asc x -> name x + Desc x -> name x <> " DESC" + _ -> error "orderClause: expected Asc or Desc, not limit or offset" + ) + orders + ) where - dummyFromOrder :: SelectOpt a -> Maybe a + dummyFromOrder :: [SelectOpt a] -> Maybe a dummyFromOrder _ = Nothing - tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromOrder o + tn = connEscapeTableName conn (entityDef $ dummyFromOrder orders) - name :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) - => EntityField record typ -> Text + name + :: (PersistEntity record) + => EntityField record typ -> Text name x = - (if includeTable - then ((tn <> ".") <>) - else id) - $ connEscapeName conn $ fieldName x + prefixByTable includeTable tn $ + connEscapeFieldName conn (fieldName x) -- | Generates sql for limit and offset for postgres, sqlite and mysql. -decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text -decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = +decorateSQLWithLimitOffset + :: Text + -> (Int, Int) + -> Text + -> Text +decorateSQLWithLimitOffset nolimit (limit, offset) sql = let lim = case (limit, offset) of - (0, 0) -> "" - (0, _) -> T.cons ' ' nolimit - (_, _) -> " LIMIT " <> T.pack (show limit) - off = if offset == 0 - then "" - else " OFFSET " <> T.pack (show offset) - in mconcat + (0, 0) -> "" + (0, _) -> T.cons ' ' nolimit + (_, _) -> " LIMIT " <> T.pack (show limit) + off = + if offset == 0 + then "" + else " OFFSET " <> T.pack (show offset) + in + mconcat [ sql , lim , off diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -1,28 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} - +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore - ( withRawQuery - , BackendKey(..) - , toSqlKey - , fromSqlKey - , getFieldName - , getTableName - , tableDBName - , fieldDBName - ) where + ( withRawQuery + , BackendKey (..) + , toSqlKey + , fromSqlKey + , getFieldName + , getTableName + , tableDBName + , fieldDBName + ) where import Control.Exception (throwIO) import Control.Monad.IO.Class -import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) -import Data.Conduit (ConduitM, (.|), runConduit) -import qualified Data.Conduit.List as CL +import Control.Monad.Trans.Reader (ReaderT, ask) import Data.Acquire (with) import qualified Data.Aeson as A import Data.ByteString.Char8 (readInteger) -import Data.Conduit (ConduitM, (.|), runConduit) +import Data.Conduit (ConduitM, runConduit, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Foldable as Foldable import Data.Function (on) @@ -30,96 +30,153 @@ import Data.List (find, nubBy) import qualified Data.Map as Map import Data.Maybe (isJust) -import Data.Monoid (mappend, (<>)) import Data.Text (Text, unpack) import qualified Data.Text as T import Data.Void (Void) +import GHC.Generics (Generic) +import Web.HttpApiData (FromHttpApiData, ToHttpApiData) import Web.PathPieces (PathPiece) -import Web.HttpApiData (ToHttpApiData, FromHttpApiData) import Database.Persist import Database.Persist.Class () import Database.Persist.Sql.Class (PersistFieldSql) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types -import Database.Persist.Sql.Util ( - dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames - , updatePersistValue, mkUpdateText, commaSeparated) +import Database.Persist.Sql.Types.Internal +import Database.Persist.Sql.Util + ( commaSeparated + , dbIdColumns + , keyAndEntityColumnNames + , mkInsertValues + , mkUpdateText + , parseEntityValues + , updatePersistValue + ) -withRawQuery :: MonadIO m - => Text - -> [PersistValue] - -> ConduitM [PersistValue] Void IO a - -> ReaderT SqlBackend m a +withRawQuery + :: (MonadIO m) + => Text + -> [PersistValue] + -> ConduitM [PersistValue] Void IO a + -> ReaderT SqlBackend m a withRawQuery sql vals sink = do srcRes <- rawQueryRes sql vals liftIO $ with srcRes (\src -> runConduit $ src .| sink) -toSqlKey :: ToBackendKey SqlBackend record => Int64 -> Key record +toSqlKey :: (ToBackendKey SqlBackend record) => Int64 -> Key record toSqlKey = fromBackendKey . SqlBackendKey -fromSqlKey :: ToBackendKey SqlBackend record => Key record -> Int64 +fromSqlKey :: (ToBackendKey SqlBackend record) => Key record -> Int64 fromSqlKey = unSqlBackendKey . toBackendKey -whereStmtForKey :: PersistEntity record => SqlBackend -> Key record -> Text +whereStmtForKey :: (PersistEntity record) => SqlBackend -> Key record -> Text whereStmtForKey conn k = - T.intercalate " AND " - $ map (<> "=? ") - $ dbIdColumns conn entDef + T.intercalate " AND " $ + Foldable.toList $ + fmap (<> "=? ") $ + dbIdColumns conn entDef where entDef = entityDef $ dummyFromKey k -whereStmtForKeys :: PersistEntity record => SqlBackend -> [Key record] -> Text +whereStmtForKeys :: (PersistEntity record) => SqlBackend -> [Key record] -> Text whereStmtForKeys conn ks = T.intercalate " OR " $ whereStmtForKey conn `fmap` ks --- | get the SQL string for the table that a PeristEntity represents +-- | get the SQL string for the table that a PersistEntity represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient tableName function -- which does not operate in a Monad -getTableName :: forall record m backend. - ( PersistEntity record - , BackendCompatible SqlBackend backend - , Monad m - ) => record -> ReaderT backend m Text -getTableName rec = withReaderT projectBackend $ do +getTableName + :: forall record m backend + . ( PersistEntity record + , BackendCompatible SqlBackend backend + , Monad m + ) + => record -> ReaderT backend m Text +getTableName rec = withCompatibleBackend $ do conn <- ask - return $ connEscapeName conn $ tableDBName rec + return $ connEscapeTableName conn (entityDef $ Just rec) -- | useful for a backend to implement tableName by adding escaping -tableDBName :: (PersistEntity record) => record -> DBName -tableDBName rec = entityDB $ entityDef (Just rec) +tableDBName :: (PersistEntity record) => record -> EntityNameDB +tableDBName rec = getEntityDBName $ entityDef (Just rec) -- | get the SQL string for the field that an EntityField represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient fieldName function -- which does not operate in a Monad -getFieldName :: forall record typ m backend. - ( PersistEntity record - , PersistEntityBackend record ~ SqlBackend - , BackendCompatible SqlBackend backend - , Monad m - ) - => EntityField record typ -> ReaderT backend m Text -getFieldName rec = withReaderT projectBackend $ do +getFieldName + :: forall record typ m backend + . ( PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , BackendCompatible SqlBackend backend + , Monad m + ) + => EntityField record typ -> ReaderT backend m Text +getFieldName rec = withCompatibleBackend $ do conn <- ask - return $ connEscapeName conn $ fieldDBName rec + return $ connEscapeFieldName conn (fieldDB $ persistFieldDef rec) -- | useful for a backend to implement fieldName by adding escaping -fieldDBName :: forall record typ. (PersistEntity record) => EntityField record typ -> DBName +fieldDBName + :: forall record typ + . (PersistEntity record) => EntityField record typ -> FieldNameDB fieldDBName = fieldDB . persistFieldDef - instance PersistCore SqlBackend where - newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } - deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) + newtype BackendKey SqlBackend = SqlBackendKey {unSqlBackendKey :: Int64} + deriving stock (Show, Read, Eq, Ord, Generic) + deriving newtype + ( Num + , Integral + , PersistField + , PersistFieldSql + , PathPiece + , ToHttpApiData + , FromHttpApiData + , Real + , Enum + , Bounded + , A.ToJSON + , A.FromJSON + ) + instance PersistCore SqlReadBackend where - newtype BackendKey SqlReadBackend = SqlReadBackendKey { unSqlReadBackendKey :: Int64 } - deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) + newtype BackendKey SqlReadBackend = SqlReadBackendKey {unSqlReadBackendKey :: Int64} + deriving stock (Show, Read, Eq, Ord, Generic) + deriving newtype + ( Num + , Integral + , PersistField + , PersistFieldSql + , PathPiece + , ToHttpApiData + , FromHttpApiData + , Real + , Enum + , Bounded + , A.ToJSON + , A.FromJSON + ) + instance PersistCore SqlWriteBackend where - newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 } - deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) + newtype BackendKey SqlWriteBackend = SqlWriteBackendKey {unSqlWriteBackendKey :: Int64} + deriving stock (Show, Read, Eq, Ord, Generic) + deriving newtype + ( Num + , Integral + , PersistField + , PersistFieldSql + , PathPiece + , ToHttpApiData + , FromHttpApiData + , Real + , Enum + , Bounded + , A.ToJSON + , A.FromJSON + ) instance BackendCompatible SqlBackend SqlBackend where projectBackend = id @@ -134,48 +191,78 @@ update _ [] = return () update k upds = do conn <- ask - let wher = whereStmtForKey conn k - let sql = T.concat - [ "UPDATE " - , connEscapeName conn $ tableDBName $ recordTypeFromKey k - , " SET " - , T.intercalate "," $ map (mkUpdateText conn) upds - , " WHERE " - , wher - ] + let + wher = whereStmtForKey conn k + let + sql = + T.concat + [ "UPDATE " + , connEscapeTableName conn (entityDef $ Just $ recordTypeFromKey k) + , " SET " + , T.intercalate "," $ map (mkUpdateText conn) upds + , " WHERE " + , wher + ] rawExecute sql $ map updatePersistValue upds `mappend` keyToValues k + insert_ val = do + conn <- ask + let + vals = mkInsertValues val + case connInsertSql conn (entityDef (Just val)) vals of + ISRSingle sql -> do + withRawQuery sql vals $ do + pure () + ISRInsertGet sql1 _sql2 -> do + rawExecute sql1 vals + ISRManyKeys sql _fs -> do + rawExecute sql vals + insert val = do conn <- ask - let esql = connInsertSql conn t vals + let + esql = connInsertSql conn t vals key <- case esql of ISRSingle sql -> withRawQuery sql vals $ do x <- CL.head case x of Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of - Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` unpack err + Left err -> + error $ + "SQL insert: keyFromValues: PersistInt64 " + `mappend` show i + `mappend` " " + `mappend` unpack err Right k -> return k Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> case keyFromValues vals' of - Left e -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ++ ". Error was: " ++ unpack e + Left e -> + error $ + "Invalid result from a SQL insert, got: " + ++ show vals' + ++ ". Error was: " + ++ unpack e Right k -> return k - ISRInsertGet sql1 sql2 -> do rawExecute sql1 vals withRawQuery sql2 [] $ do mm <- CL.head - let m = maybe - (Left $ "No results from ISRInsertGet: " `mappend` tshow (sql1, sql2)) - Right mm + let + m = + maybe + (Left $ "No results from ISRInsertGet: " `mappend` tshow (sql1, sql2)) + Right + mm -- TODO: figure out something better for MySQL - let convert x = + let + convert x = case x of [PersistByteString i] -> case readInteger i of -- mssql - Just (ret,"") -> [PersistInt64 $ fromIntegral ret] - _ -> x + Just (ret, "") -> [PersistInt64 $ fromIntegral ret] + _ -> x _ -> x -- Yes, it's just <|>. Older bases don't have the -- instance for Either. @@ -188,21 +275,27 @@ ISRManyKeys sql fs -> do rawExecute sql vals case entityPrimary t of - Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql - Just pdef -> - let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs - in case keyFromValues keyvals of + Nothing -> + error $ "ISRManyKeys is used when Primary is defined " ++ show sql + Just pdef -> + let + pks = Foldable.toList $ fmap fieldHaskell $ compositeFields pdef + keyvals = + map snd $ + filter (\(a, _) -> let ret = isJust (find (== a) pks) in ret) $ + zip (map fieldHaskell $ getEntityFields t) fs + in + case keyFromValues keyvals of Right k -> return k - Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e + Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e return key where - tshow :: Show a => a -> Text + tshow :: (Show a) => a -> Text tshow = T.pack . show throw = liftIO . throwIO . userError . T.unpack t = entityDef $ Just val - vals = map toPersistValue $ toPersistFields val + vals = mkInsertValues val insertMany [] = return [] insertMany vals = do @@ -214,97 +307,117 @@ case insertManyFn ent valss of ISRSingle sql -> rawSql sql (concat valss) _ -> error "ISRSingle is expected from the connInsertManySql function" - where - ent = entityDef vals - valss = map (map toPersistValue . toPersistFields) vals + where + ent = entityDef vals + valss = map mkInsertValues vals - insertMany_ vals0 = runChunked (length $ entityFields t) insertMany_' vals0 + insertMany_ vals0 = runChunked (length $ getEntityFields t) insertMany_' vals0 where t = entityDef vals0 insertMany_' vals = do - conn <- ask - let valss = map (map toPersistValue . toPersistFields) vals - let sql = T.concat - [ "INSERT INTO " - , connEscapeName conn (entityDB t) - , "(" - , T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t - , ") VALUES (" - , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields t) - , ")" - ] - rawExecute sql (concat valss) + conn <- ask + let + valss = map mkInsertValues vals + let + sql = + T.concat + [ "INSERT INTO " + , connEscapeTableName conn t + , "(" + , T.intercalate "," $ map (connEscapeFieldName conn . fieldDB) $ getEntityFields t + , ") VALUES (" + , T.intercalate "),(" $ + replicate (length valss) $ + T.intercalate "," $ + map (const "?") (getEntityFields t) + , ")" + ] + rawExecute sql (concat valss) replace k val = do conn <- ask - let t = entityDef $ Just val - let wher = whereStmtForKey conn k - let sql = T.concat - [ "UPDATE " - , connEscapeName conn (entityDB t) - , " SET " - , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) - , " WHERE " - , wher - ] - vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k + let + t = entityDef $ Just val + let + wher = whereStmtForKey conn k + let + sql = + T.concat + [ "UPDATE " + , connEscapeTableName conn t + , " SET " + , T.intercalate "," (map (go conn . fieldDB) $ getEntityFields t) + , " WHERE " + , wher + ] + vals = mkInsertValues val `mappend` keyToValues k rawExecute sql vals where - go conn x = connEscapeName conn x `T.append` "=?" + go conn x = connEscapeFieldName conn x `T.append` "=?" insertKey k v = insrepHelper "INSERT" [Entity k v] insertEntityMany es' = do conn <- ask - let entDef = entityDef $ map entityVal es' - let columnNames = keyAndEntityColumnNames entDef conn + let + entDef = entityDef $ map entityVal es' + let + columnNames = keyAndEntityColumnNames entDef conn runChunked (length columnNames) go es' where go = insrepHelper "INSERT" - repsert key value = do - mExisting <- get key - case mExisting of - Nothing -> insertKey key value - Just _ -> replace key value + repsert key value = repsertMany [(key, value)] repsertMany [] = return () repsertMany krsDups = do conn <- ask - let krs = nubBy ((==) `on` fst) (reverse krsDups) - let rs = snd `fmap` krs - let ent = entityDef rs - let nr = length krs - let toVals (k,r) - = case entityPrimary ent of - Nothing -> keyToValues k <> (toPersistValue <$> toPersistFields r) - Just _ -> toPersistValue <$> toPersistFields r + let + krs = nubBy ((==) `on` fst) (reverse krsDups) + let + rs = snd `fmap` krs + let + ent = entityDef rs + let + nr = length krs + let + toVals (k, r) = + case entityPrimary ent of + Nothing -> keyToValues k <> (mkInsertValues r) + Just _ -> mkInsertValues r case connRepsertManySql conn of (Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals krs) - Nothing -> mapM_ (uncurry repsert) krs + Nothing -> mapM_ repsert' krs + where + repsert' (key, value) = do + mExisting <- get key + case mExisting of + Nothing -> insertKey key value + Just _ -> replace key value delete k = do conn <- ask rawExecute (sql conn) (keyToValues k) where wher conn = whereStmtForKey conn k - sql conn = T.concat - [ "DELETE FROM " - , connEscapeName conn $ tableDBName $ recordTypeFromKey k - , " WHERE " - , wher conn - ] + sql conn = + T.concat + [ "DELETE FROM " + , connEscapeTableName conn (entityDef $ Just $ recordTypeFromKey k) + , " WHERE " + , wher conn + ] instance PersistStoreWrite SqlWriteBackend where - insert v = withReaderT persistBackend $ insert v - insertMany vs = withReaderT persistBackend $ insertMany vs - insertMany_ vs = withReaderT persistBackend $ insertMany_ vs - insertEntityMany vs = withReaderT persistBackend $ insertEntityMany vs - insertKey k v = withReaderT persistBackend $ insertKey k v - repsert k v = withReaderT persistBackend $ repsert k v - replace k v = withReaderT persistBackend $ replace k v - delete k = withReaderT persistBackend $ delete k - update k upds = withReaderT persistBackend $ update k upds - repsertMany krs = withReaderT persistBackend $ repsertMany krs + insert v = withBaseBackend $ insert v + insertMany vs = withBaseBackend $ insertMany vs + insertMany_ vs = withBaseBackend $ insertMany_ vs + insertEntityMany vs = withBaseBackend $ insertEntityMany vs + insertKey k v = withBaseBackend $ insertKey k v + repsert k v = withBaseBackend $ repsert k v + replace k v = withBaseBackend $ replace k v + delete k = withBaseBackend $ delete k + update k upds = withBaseBackend $ update k upds + repsertMany krs = withBaseBackend $ repsertMany krs instance PersistStoreRead SqlBackend where get k = do @@ -312,34 +425,43 @@ return $ Map.lookup k mEs -- inspired by Database.Persist.Sql.Orphan.PersistQuery.selectSourceRes - getMany [] = return Map.empty - getMany ks@(k:_)= do + getMany [] = return Map.empty + getMany ks@(k : _) = do conn <- ask - let t = entityDef . dummyFromKey $ k - let cols = commaSeparated . entityColumnNames t - let wher = whereStmtForKeys conn ks - let sql = T.concat - [ "SELECT " - , cols conn - , " FROM " - , connEscapeName conn $ entityDB t - , " WHERE " - , wher - ] - let parse vals - = case parseEntityValues t vals of - Left s -> liftIO $ throwIO $ PersistMarshalError s + let + t = entityDef . dummyFromKey $ k + let + cols = commaSeparated . Foldable.toList . keyAndEntityColumnNames t + let + wher = whereStmtForKeys conn ks + let + sql = + T.concat + [ "SELECT " + , cols conn + , " FROM " + , connEscapeTableName conn t + , " WHERE " + , wher + ] + let + parse vals = + case parseEntityValues t vals of + Left s -> + liftIO $ + throwIO $ + PersistMarshalError ("getBy: " <> s) Right row -> return row withRawQuery sql (Foldable.foldMap keyToValues ks) $ do es <- CL.mapM parse .| CL.consume return $ Map.fromList $ fmap (\e -> (entityKey e, entityVal e)) es instance PersistStoreRead SqlReadBackend where - get k = withReaderT persistBackend $ get k - getMany ks = withReaderT persistBackend $ getMany ks + get k = withBaseBackend $ get k + getMany ks = withBaseBackend $ getMany ks instance PersistStoreRead SqlWriteBackend where - get k = withReaderT persistBackend $ get k - getMany ks = withReaderT persistBackend $ getMany ks + get k = withBaseBackend $ get k + getMany ks = withBaseBackend $ getMany ks dummyFromKey :: Key record -> Maybe record dummyFromKey = Just . recordTypeFromKey @@ -347,27 +469,33 @@ recordTypeFromKey :: Key record -> record recordTypeFromKey _ = error "dummyFromKey" -insrepHelper :: (MonadIO m, PersistEntity val) - => Text - -> [Entity val] - -> ReaderT SqlBackend m () -insrepHelper _ [] = return () +insrepHelper + :: (MonadIO m, PersistEntity val) + => Text + -> [Entity val] + -> ReaderT SqlBackend m () +insrepHelper _ [] = return () insrepHelper command es = do conn <- ask - let columnNames = keyAndEntityColumnNames entDef conn + let + columnNames = Foldable.toList $ keyAndEntityColumnNames entDef conn rawExecute (sql conn columnNames) vals where entDef = entityDef $ map entityVal es - sql conn columnNames = T.concat - [ command - , " INTO " - , connEscapeName conn (entityDB entDef) - , "(" - , T.intercalate "," columnNames - , ") VALUES (" - , T.intercalate "),(" $ replicate (length es) $ T.intercalate "," $ map (const "?") columnNames - , ")" - ] + sql conn columnNames = + T.concat + [ command + , " INTO " + , connEscapeTableName conn entDef + , "(" + , T.intercalate "," columnNames + , ") VALUES (" + , T.intercalate "),(" $ + replicate (length es) $ + T.intercalate "," $ + fmap (const "?") columnNames + , ")" + ] vals = Foldable.foldMap entityValues es runChunked @@ -376,13 +504,16 @@ -> ([a] -> ReaderT SqlBackend m ()) -> [a] -> ReaderT SqlBackend m () -runChunked _ _ [] = return () +runChunked _ _ [] = return () runChunked width m xs = do conn <- ask case connMaxParams conn of Nothing -> m xs - Just maxParams -> let chunkSize = maxParams `div` width in - mapM_ m (chunksOf chunkSize xs) + Just maxParams -> + let + chunkSize = maxParams `div` width + in + mapM_ m (chunksOf chunkSize xs) -- Implement this here to avoid depending on the split package chunksOf :: Int -> [a] -> [[a]] diff --git a/Database/Persist/Sql/Orphan/PersistUnique.hs b/Database/Persist/Sql/Orphan/PersistUnique.hs --- a/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -1,133 +1,168 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Database.Persist.Sql.Orphan.PersistUnique - () - where +{-# LANGUAGE ExplicitForAll #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Sql.Orphan.PersistUnique () +where + import Control.Exception (throwIO) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Monad.Trans.Reader (ask, withReaderT, ReaderT) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader (ask) import qualified Data.Conduit.List as CL +import Data.Foldable (toList) import Data.Function (on) import Data.List (nubBy) -import Data.Monoid (mappend) import qualified Data.Text as T import Database.Persist -import Database.Persist.Class.PersistUnique (defaultPutMany, persistUniqueKeyValues, onlyOneUniqueDef) -import Database.Persist.Sql.Types -import Database.Persist.Sql.Raw -import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) -import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText') +import Database.Persist.Class.PersistUnique + ( defaultPutMany + , defaultUpsertBy + , persistUniqueKeyValues + ) -defaultUpsert - :: - ( MonadIO m - , PersistEntity record - , PersistUniqueWrite backend - , PersistEntityBackend record ~ BaseBackend backend - , OnlyOneUniqueKey record +import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Types.Internal +import Database.Persist.Sql.Util + ( dbColumns + , mkUpdateText' + , parseEntityValues + , parseExistsResult + , updatePersistValue ) - => record -> [Update record] -> ReaderT backend m (Entity record) -defaultUpsert record updates = do - uniqueKey <- onlyUnique record - upsertBy uniqueKey record updates instance PersistUniqueWrite SqlBackend where - upsert record updates = do - conn <- ask - let escape = connEscapeName conn - let refCol n = T.concat [escape (entityDB t), ".", n] - let mkUpdateText = mkUpdateText' escape refCol - uniqueKey <- onlyUnique record - case connUpsertSql conn of - Just upsertSql -> case updates of - [] -> defaultUpsert record updates - _:_ -> do - let upds = T.intercalate "," $ map mkUpdateText updates - sql = upsertSql t (pure (onlyOneUniqueDef (Just record))) upds - vals = map toPersistValue (toPersistFields record) - ++ map updatePersistValue updates - ++ unqs uniqueKey + upsertBy uniqueKey record updates = do + conn <- ask + let + refCol n = T.concat [connEscapeTableName conn t, ".", n] + let + mkUpdateText = mkUpdateText' (connEscapeFieldName conn) refCol + case connUpsertSql conn of + Just upsertSql -> case updates of + [] -> defaultUpsertBy uniqueKey record updates + _ : _ -> do + let + upds = T.intercalate "," $ map mkUpdateText updates + sql = upsertSql t (persistUniqueToFieldNames uniqueKey) upds + vals = + map toPersistValue (toPersistFields record) + ++ map updatePersistValue updates + ++ unqs uniqueKey - x <- rawSql sql vals - return $ head x - Nothing -> defaultUpsert record updates - where - t = entityDef $ Just record - unqs uniqueKey = concatMap persistUniqueToValues [uniqueKey] + x <- rawSql sql vals + return $ head x + Nothing -> defaultUpsertBy uniqueKey record updates + where + t = entityDef $ Just record + unqs uniqueKey' = concatMap persistUniqueToValues [uniqueKey'] deleteBy uniq = do conn <- ask - let sql' = sql conn + let + sql' = sql conn vals = persistUniqueToValues uniq rawExecute sql' vals where t = entityDef $ dummyFromUnique uniq - go = map snd . persistUniqueToFieldNames - go' conn x = connEscapeName conn x `mappend` "=?" + go = toList . fmap snd . persistUniqueToFieldNames + go' conn x = connEscapeFieldName conn x `mappend` "=?" sql conn = T.concat [ "DELETE FROM " - , connEscapeName conn $ entityDB t + , connEscapeTableName conn t , " WHERE " - , T.intercalate " AND " $ map (go' conn) $ go uniq] + , T.intercalate " AND " $ map (go' conn) $ go uniq + ] putMany [] = return () putMany rsD = do - let uKeys = persistUniqueKeys . head $ rsD + let + uKeys = persistUniqueKeys . head $ rsD case uKeys of [] -> insertMany_ rsD _ -> go - where - go = do - let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD) - let ent = entityDef rs - let nr = length rs - let toVals r = map toPersistValue $ toPersistFields r + where + go = do + let + rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD) + let + ent = entityDef rs + let + nr = length rs + let + toVals r = map toPersistValue $ toPersistFields r conn <- ask case connPutManySql conn of (Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals rs) Nothing -> defaultPutMany rs instance PersistUniqueWrite SqlWriteBackend where - deleteBy uniq = withReaderT persistBackend $ deleteBy uniq - upsert rs us = withReaderT persistBackend $ upsert rs us - putMany rs = withReaderT persistBackend $ putMany rs + deleteBy uniq = withBaseBackend $ deleteBy uniq + upsert rs us = withBaseBackend $ upsert rs us + putMany rs = withBaseBackend $ putMany rs instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask - let sql = + let + sql = T.concat [ "SELECT " - , T.intercalate "," $ dbColumns conn t + , T.intercalate "," $ toList $ dbColumns conn t , " FROM " - , connEscapeName conn $ entityDB t + , connEscapeTableName conn t , " WHERE " - , sqlClause conn] + , sqlClause conn + ] uvals = persistUniqueToValues uniq withRawQuery sql uvals $ - do row <- CL.head - case row of - Nothing -> return Nothing - Just [] -> error "getBy: empty row" - Just vals -> - case parseEntityValues t vals of - Left err -> - liftIO $ throwIO $ PersistMarshalError err - Right r -> return $ Just r + do + row <- CL.head + case row of + Nothing -> return Nothing + Just [] -> error "getBy: empty row" + Just vals -> + case parseEntityValues t vals of + Left err -> + liftIO $ throwIO $ PersistMarshalError err + Right r -> return $ Just r where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq - go conn x = connEscapeName conn x `mappend` "=?" + go conn x = connEscapeFieldName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq - toFieldNames' = map snd . persistUniqueToFieldNames + toFieldNames' = toList . fmap snd . persistUniqueToFieldNames + existsBy uniq = do + conn <- ask + let + sql = + T.concat + [ "SELECT EXISTS(SELECT 1 FROM " + , connEscapeTableName conn t + , " WHERE " + , sqlClause conn + , ")" + ] + uvals = persistUniqueToValues uniq + withRawQuery sql uvals $ do + mm <- CL.head + return $ parseExistsResult mm sql "PersistUnique.existsBy" + where + sqlClause conn = + T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq + go conn x = connEscapeFieldName conn x `mappend` "=?" + t = entityDef $ dummyFromUnique uniq + toFieldNames' = toList . fmap snd . persistUniqueToFieldNames + instance PersistUniqueRead SqlReadBackend where - getBy uniq = withReaderT persistBackend $ getBy uniq + getBy uniq = withBaseBackend $ getBy uniq + existsBy uniq = withBaseBackend $ existsBy uniq instance PersistUniqueRead SqlWriteBackend where - getBy uniq = withReaderT persistBackend $ getBy uniq + getBy uniq = withBaseBackend $ getBy uniq + existsBy uniq = withBaseBackend $ existsBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing diff --git a/Database/Persist/Sql/Raw.hs b/Database/Persist/Sql/Raw.hs --- a/Database/Persist/Sql/Raw.hs +++ b/Database/Persist/Sql/Raw.hs @@ -1,27 +1,29 @@ module Database.Persist.Sql.Raw where import Control.Exception (throwIO) -import Control.Monad (when, liftM) +import Control.Monad (liftM, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (logDebugNS, runLoggingT) -import Control.Monad.Reader (ReaderT, ask, MonadReader) -import Control.Monad.Trans.Resource (MonadResource,release) -import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) +import Control.Monad.Reader (MonadReader, ReaderT, ask) +import Control.Monad.Trans.Resource (MonadResource, release) +import Data.Acquire (Acquire, allocateAcquire, mkAcquire, with) import Data.Conduit -import Data.IORef (writeIORef, readIORef, newIORef) -import qualified Data.Map as Map +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Int (Int64) import Data.Text (Text, pack) import qualified Data.Text as T import Database.Persist -import Database.Persist.Sql.Types import Database.Persist.Sql.Class +import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal +import Database.Persist.SqlBackend.Internal.StatementCache -rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) - => Text - -> [PersistValue] - -> ConduitM () [PersistValue] m () +rawQuery + :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) + => Text + -> [PersistValue] + -> ConduitM () [PersistValue] m () rawQuery sql vals = do srcRes <- liftPersist $ rawQueryRes sql vals (releaseKey, src) <- allocateAcquire srcRes @@ -35,8 +37,10 @@ -> ReaderT env m1 (Acquire (ConduitM () [PersistValue] m2 ())) rawQueryRes sql vals = do conn <- projectBackend `liftM` ask - let make = do - runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) + let + make = do + runLoggingT + (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) getStmtConn conn sql return $ do @@ -44,21 +48,28 @@ stmtQuery stmt vals -- | Execute a raw SQL statement -rawExecute :: (MonadIO m, BackendCompatible SqlBackend backend) - => Text -- ^ SQL statement, possibly with placeholders. - -> [PersistValue] -- ^ Values to fill the placeholders. - -> ReaderT backend m () +rawExecute + :: (MonadIO m, BackendCompatible SqlBackend backend) + => Text + -- ^ SQL statement, possibly with placeholders. + -> [PersistValue] + -- ^ Values to fill the placeholders. + -> ReaderT backend m () rawExecute x y = liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified. -rawExecuteCount :: (MonadIO m, BackendCompatible SqlBackend backend) - => Text -- ^ SQL statement, possibly with placeholders. - -> [PersistValue] -- ^ Values to fill the placeholders. - -> ReaderT backend m Int64 +rawExecuteCount + :: (MonadIO m, BackendCompatible SqlBackend backend) + => Text + -- ^ SQL statement, possibly with placeholders. + -> [PersistValue] + -- ^ Values to fill the placeholders. + -> ReaderT backend m Int64 rawExecuteCount sql vals = do conn <- projectBackend `liftM` ask - runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) + runLoggingT + (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals @@ -66,42 +77,49 @@ return res getStmt - :: (MonadIO m, BackendCompatible SqlBackend backend) - => Text -> ReaderT backend m Statement + :: (MonadIO m, MonadReader backend m, BackendCompatible SqlBackend backend) + => Text -> m Statement getStmt sql = do conn <- projectBackend `liftM` ask liftIO $ getStmtConn conn sql getStmtConn :: SqlBackend -> Text -> IO Statement getStmtConn conn sql = do - smap <- liftIO $ readIORef $ connStmtMap conn - case Map.lookup sql smap of - Just stmt -> return stmt + let + cacheK = mkCacheKeyFromQuery sql + mstmt <- statementCacheLookup (connStmtMap conn) cacheK + stmt <- case mstmt of + Just stmt -> pure stmt Nothing -> do stmt' <- liftIO $ connPrepare conn sql iactive <- liftIO $ newIORef True - let stmt = Statement - { stmtFinalize = do - active <- readIORef iactive - when active $ do stmtFinalize stmt' - writeIORef iactive False - , stmtReset = do - active <- readIORef iactive - when active $ stmtReset stmt' - , stmtExecute = \x -> do - active <- readIORef iactive - if active - then stmtExecute stmt' x - else throwIO $ StatementAlreadyFinalized sql - , stmtQuery = \x -> do - active <- liftIO $ readIORef iactive - if active - then stmtQuery stmt' x - else liftIO $ throwIO $ StatementAlreadyFinalized sql - } - liftIO $ writeIORef (connStmtMap conn) $ Map.insert sql stmt smap - return stmt + let + stmt = + Statement + { stmtFinalize = do + active <- readIORef iactive + when active $ do + stmtFinalize stmt' + writeIORef iactive False + , stmtReset = do + active <- readIORef iactive + when active $ stmtReset stmt' + , stmtExecute = \x -> do + active <- readIORef iactive + if active + then stmtExecute stmt' x + else throwIO $ StatementAlreadyFinalized sql + , stmtQuery = \x -> do + active <- liftIO $ readIORef iactive + if active + then stmtQuery stmt' x + else liftIO $ throwIO $ StatementAlreadyFinalized sql + } + liftIO $ statementCacheInsert (connStmtMap conn) cacheK stmt + pure stmt + (hookGetStatement $ connHooks conn) conn sql stmt + -- | Execute a raw SQL statement and return its results as a -- list. If you do not expect a return value, use of -- `rawExecute` is recommended. @@ -198,57 +216,69 @@ -- > xs <- getPerson -- > liftIO (print xs) -- > - -rawSql :: (RawSql a, MonadIO m, BackendCompatible SqlBackend backend) - => Text -- ^ SQL statement, possibly with placeholders. - -> [PersistValue] -- ^ Values to fill the placeholders. - -> ReaderT backend m [a] +rawSql + :: (RawSql a, MonadIO m, BackendCompatible SqlBackend backend) + => Text + -- ^ SQL statement, possibly with placeholders. + -> [PersistValue] + -- ^ Values to fill the placeholders. + -> ReaderT backend m [a] rawSql stmt = run - where - getType :: (x -> m [a]) -> a - getType = error "rawSql.getType" + where + getType :: (x -> m [a]) -> a + getType = error "rawSql.getType" - x = getType run - process = rawSqlProcessRow + x = getType run + process = rawSqlProcessRow - withStmt' colSubsts params sink = do - srcRes <- rawQueryRes sql params - liftIO $ with srcRes (\src -> runConduit $ src .| sink) + withStmt' colSubsts params sink = do + srcRes <- rawQueryRes sql params + liftIO $ with srcRes (\src -> runConduit $ src .| sink) + where + sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt + placeholder = "??" + makeSubsts (s : ss) (t : ts) = t : s : makeSubsts ss ts + makeSubsts [] [] = [] + makeSubsts [] ts = [T.intercalate placeholder ts] + makeSubsts ss [] = error (concat err) where - sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt - placeholder = "??" - makeSubsts (s:ss) (t:ts) = t : s : makeSubsts ss ts - makeSubsts [] [] = [] - makeSubsts [] ts = [T.intercalate placeholder ts] - makeSubsts ss [] = error (concat err) - where - err = [ "rawsql: there are still ", show (length ss) - , "'??' placeholder substitutions to be made " - , "but all '??' placeholders have already been " - , "consumed. Please read 'rawSql's documentation " - , "on how '??' placeholders work." - ] + err = + [ "rawsql: there are still " + , show (length ss) + , "'??' placeholder substitutions to be made " + , "but all '??' placeholders have already been " + , "consumed. Please read 'rawSql's documentation " + , "on how '??' placeholders work." + ] - run params = do + run params = do conn <- projectBackend `liftM` ask - let (colCount, colSubsts) = rawSqlCols (connEscapeName conn) x + let + (colCount, colSubsts) = rawSqlCols (connEscapeRawName conn) x withStmt' colSubsts params $ firstRow colCount - firstRow colCount = do + firstRow colCount = do mrow <- await case mrow of - Nothing -> return [] - Just row - | colCount == length row -> getter mrow - | otherwise -> fail $ concat - [ "rawSql: wrong number of columns, got " - , show (length row), " but expected ", show colCount - , " (", rawSqlColCountReason x, ")." ] + Nothing -> return [] + Just row + | colCount == length row -> getter mrow + | otherwise -> + fail $ + concat + [ "rawSql: wrong number of columns, got " + , show (length row) + , " but expected " + , show colCount + , " (" + , rawSqlColCountReason x + , ")." + ] - getter = go id - where - go acc Nothing = return (acc []) - go acc (Just row) = - case process row of + getter = go id + where + go acc Nothing = return (acc []) + go acc (Just row) = + case process row of Left err -> fail (T.unpack err) - Right r -> await >>= go (acc . (r:)) + Right r -> await >>= go (acc . (r :)) diff --git a/Database/Persist/Sql/Run.hs b/Database/Persist/Sql/Run.hs --- a/Database/Persist/Sql/Run.hs +++ b/Database/Persist/Sql/Run.hs @@ -1,130 +1,147 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} + module Database.Persist.Sql.Run where -import Control.Exception (bracket, mask, onException) -import Control.Monad (liftM) +import Control.Monad (void) import Control.Monad.IO.Unlift -import qualified UnliftIO.Exception as UE import Control.Monad.Logger.CallStack import Control.Monad.Reader (MonadReader) import qualified Control.Monad.Reader as MonadReader import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource -import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with) -import Data.IORef (readIORef) -import Data.Pool (Pool, LocalPool) +import Data.Acquire (Acquire, ReleaseType (..), mkAcquireType, with) import Data.Pool as P -import qualified Data.Map as Map import qualified Data.Text as T -import System.Timeout (timeout) +import qualified UnliftIO.Exception as UE import Database.Persist.Class.PersistStore -import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel) import Database.Persist.Sql.Raw - --- | The returned 'Acquire' gets a connection from the pool, but does __NOT__ --- start a new transaction. Used to implement 'acquireSqlConnFromPool' and --- 'acquireSqlConnFromPoolWithIsolation', this is useful for performing actions --- on a connection that cannot be done within a transaction, such as VACUUM in --- Sqlite. --- --- @since 2.10.5 -unsafeAcquireSqlConnFromPool - :: forall backend m - . (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) - => m (Acquire backend) -unsafeAcquireSqlConnFromPool = do - pool <- MonadReader.ask - - let freeConn :: (backend, LocalPool backend) -> ReleaseType -> IO () - freeConn (res, localPool) relType = case relType of - ReleaseException -> P.destroyResource pool localPool res - _ -> P.putResource localPool res - - return $ fst <$> mkAcquireType (P.takeResource pool) freeConn - -{-# DEPRECATED unsafeAcquireSqlConnFromPool "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-} - - --- | The returned 'Acquire' gets a connection from the pool, starts a new --- transaction and gives access to the prepared connection. --- --- When the acquired connection is released the transaction is committed and --- the connection returned to the pool. --- --- Upon an exception the transaction is rolled back and the connection --- destroyed. --- --- This is equivalent to 'runSqlPool' but does not incur the 'MonadUnliftIO' --- constraint, meaning it can be used within, for example, a 'Conduit' --- pipeline. --- --- @since 2.10.5 -acquireSqlConnFromPool - :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) - => m (Acquire backend) -acquireSqlConnFromPool = do - connFromPool <- unsafeAcquireSqlConnFromPool - return $ connFromPool >>= acquireSqlConn - -{-# DEPRECATED acquireSqlConnFromPool "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-} --- --- | Like 'acquireSqlConnFromPool', but lets you specify an explicit isolation --- level. --- --- @since 2.10.5 -acquireSqlConnFromPoolWithIsolation - :: (MonadReader (Pool backend) m, BackendCompatible SqlBackend backend) - => IsolationLevel -> m (Acquire backend) -acquireSqlConnFromPoolWithIsolation isolation = do - connFromPool <- unsafeAcquireSqlConnFromPool - return $ connFromPool >>= acquireSqlConnWithIsolation isolation - -{-# DEPRECATED acquireSqlConnFromPoolWithIsolation "The Pool ~> Acquire functions are unpredictable and may result in resource leaks with asynchronous exceptions. They will be removed in 2.12. If you need them, please file an issue and we'll try to help get you sorted. See issue #1199 on GitHub for the debugging log." #-} +import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal +import Database.Persist.SqlBackend.Internal.SqlPoolHooks +import Database.Persist.SqlBackend.Internal.StatementCache -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. -- +-- This function performs the given action in a transaction. If an +-- exception occurs during the action, then the transaction is rolled back. +-- -- Note: This function previously timed out after 2 seconds, but this behavior -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. runSqlPool - :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> m a -runSqlPool r pconn = - withRunInIO $ \runInIO -> - withResource pconn $ \conn -> - mask $ \restore -> do - let sqlBackend = projectBackend conn - let getter = getStmtConn sqlBackend - restore $ connBegin sqlBackend getter Nothing - a <- restore (runInIO (runReaderT r conn)) - `UE.catchAny` \e -> do - restore $ connRollback sqlBackend getter - UE.throwIO e - restore $ connCommit sqlBackend getter - pure a +runSqlPool r pconn = do + rawRunSqlPool r pconn Nothing -- | Like 'runSqlPool', but supports specifying an isolation level. -- -- @since 2.9.0 runSqlPoolWithIsolation - :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a runSqlPoolWithIsolation r pconn i = + rawRunSqlPool r pconn (Just i) + +-- | Like 'runSqlPool', but does not surround the action in a transaction. +-- This action might leave your database in a weird state. +-- +-- @since 2.12.0.0 +runSqlPoolNoTransaction + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a +runSqlPoolNoTransaction r pconn i = + runSqlPoolWithHooks r pconn i (\_ -> pure ()) (\_ -> pure ()) (\_ _ -> pure ()) + +rawRunSqlPool + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a +rawRunSqlPool r pconn mi = + runSqlPoolWithHooks r pconn mi before after onException + where + before conn = do + let + sqlBackend = projectBackend conn + let + getter = getStmtConn sqlBackend + liftIO $ connBegin sqlBackend getter mi + after conn = do + let + sqlBackend = projectBackend conn + let + getter = getStmtConn sqlBackend + liftIO $ connCommit sqlBackend getter + onException conn _ = do + let + sqlBackend = projectBackend conn + let + getter = getStmtConn sqlBackend + liftIO $ connRollback sqlBackend getter + +-- | This function is how 'runSqlPool' and 'runSqlPoolNoTransaction' are +-- defined. In addition to the action to be performed and the 'Pool' of +-- conections to use, we give you the opportunity to provide three actions +-- - initialize, afterwards, and onException. +-- +-- @since 2.12.0.0 +runSqlPoolWithHooks + :: forall backend m a before after onException + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a + -> Pool backend + -> Maybe IsolationLevel + -> (backend -> m before) + -- ^ Run this action immediately before the action is performed. + -> (backend -> m after) + -- ^ Run this action immediately after the action is completed. + -> (backend -> UE.SomeException -> m onException) + -- ^ This action is performed when an exception is received. The + -- exception is provided as a convenience - it is rethrown once this + -- cleanup function is complete. + -> m a +runSqlPoolWithHooks r pconn i before after onException = + runSqlPoolWithExtensibleHooks r pconn i $ + SqlPoolHooks + { alterBackend = pure + , runBefore = \conn _ -> void $ before conn + , runAfter = \conn _ -> void $ after conn + , runOnException = \b _ e -> void $ onException b e + } + +-- | This function is how 'runSqlPoolWithHooks' is defined. +-- +-- It's currently the most general function for using a SQL pool. +-- +-- @since 2.13.0.0 +runSqlPoolWithExtensibleHooks + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a + -> Pool backend + -> Maybe IsolationLevel + -> SqlPoolHooks m backend + -> m a +runSqlPoolWithExtensibleHooks r pconn i SqlPoolHooks{..} = withRunInIO $ \runInIO -> - withResource pconn $ \conn -> - mask $ \restore -> do - let sqlBackend = projectBackend conn - let getter = getStmtConn sqlBackend - restore $ connBegin sqlBackend getter (Just i) - a <- restore (runInIO (runReaderT r conn)) - `UE.catchAny` \e -> do - restore $ connRollback sqlBackend getter - UE.throwIO e - restore $ connCommit sqlBackend getter - pure a + withResource pconn $ \conn -> + UE.mask $ \restore -> do + conn' <- restore $ runInIO $ alterBackend conn + _ <- restore $ runInIO $ runBefore conn' i + a <- + restore (runInIO (runReaderT r conn')) + `UE.catchAny` \e -> do + _ <- restore $ runInIO $ runOnException conn' i e + UE.throwIO e + _ <- restore $ runInIO $ runAfter conn' i + pure a rawAcquireSqlConn :: forall backend m @@ -132,7 +149,8 @@ => Maybe IsolationLevel -> m (Acquire backend) rawAcquireSqlConn isolation = do conn <- MonadReader.ask - let rawConn :: SqlBackend + let + rawConn :: SqlBackend rawConn = projectBackend conn getter :: T.Text -> IO Statement @@ -143,7 +161,8 @@ finishTransaction :: backend -> ReleaseType -> IO () finishTransaction _ relType = case relType of - ReleaseException -> connRollback rawConn getter + ReleaseException -> do + connRollback rawConn getter _ -> connCommit rawConn getter return $ mkAcquireType beginTransaction finishTransaction @@ -155,7 +174,7 @@ -- Upon an exception the transaction is rolled back and the connection -- destroyed. -- --- This is equivalent to 'runSqlConn but does not incur the 'MonadUnliftIO' +-- This is equivalent to 'runSqlConn' but does not incur the 'MonadUnliftIO' -- constraint, meaning it can be used within, for example, a 'Conduit' -- pipeline. -- @@ -173,15 +192,21 @@ => IsolationLevel -> m (Acquire backend) acquireSqlConnWithIsolation = rawAcquireSqlConn . Just -runSqlConn :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> m a +runSqlConn + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a -> backend -> m a runSqlConn r conn = with (acquireSqlConn conn) $ runReaderT r -- | Like 'runSqlConn', but supports specifying an isolation level. -- -- @since 2.9.0 -runSqlConnWithIsolation :: (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> backend -> IsolationLevel -> m a +runSqlConnWithIsolation + :: forall backend m a + . (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a -> backend -> IsolationLevel -> m a runSqlConnWithIsolation r conn isolation = - with (acquireSqlConnWithIsolation isolation conn) $ runReaderT r + with (acquireSqlConnWithIsolation isolation conn) $ runReaderT r runSqlPersistM :: (BackendCompatible SqlBackend backend) @@ -194,45 +219,84 @@ runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool liftSqlPersistMPool - :: (MonadIO m, BackendCompatible SqlBackend backend) + :: forall backend m a + . (MonadIO m, BackendCompatible SqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> m a liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool) withSqlPool - :: (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend) - => (LogFunc -> IO backend) -- ^ create a new connection - -> Int -- ^ connection count + :: forall backend m a + . (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend) + => (LogFunc -> IO backend) + -- ^ create a new connection + -> Int + -- ^ connection count -> (Pool backend -> m a) -> m a -withSqlPool mkConn connCount f = withUnliftIO $ \u -> bracket - (unliftIO u $ createSqlPool mkConn connCount) - destroyAllResources - (unliftIO u . f) +withSqlPool mkConn connCount f = + withSqlPoolWithConfig + mkConn + (defaultConnectionPoolConfig{connectionPoolConfigSize = connCount}) + f +-- | Creates a pool of connections to a SQL database which can be used by the @Pool backend -> m a@ function. +-- After the function completes, the connections are destroyed. +-- +-- @since 2.11.0.0 +withSqlPoolWithConfig + :: forall backend m a + . (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend) + => (LogFunc -> IO backend) + -- ^ Function to create a new connection + -> ConnectionPoolConfig + -> (Pool backend -> m a) + -> m a +withSqlPoolWithConfig mkConn poolConfig f = withUnliftIO $ \u -> + UE.bracket + (unliftIO u $ createSqlPoolWithConfig mkConn poolConfig) + destroyAllResources + (unliftIO u . f) + createSqlPool - :: forall m backend. (MonadLogger m, MonadUnliftIO m, BackendCompatible SqlBackend backend) + :: forall backend m + . (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -> Int -> m (Pool backend) -createSqlPool mkConn size = do - logFunc <- askLogFunc - -- Resource pool will swallow any exceptions from close. We want to log - -- them instead. - let loggedClose :: backend -> IO () - loggedClose backend = close' backend `UE.catchAny` \e -> runLoggingT - (logError $ T.pack $ "Error closing database connection in pool: " ++ show e) - logFunc - liftIO $ createPool (mkConn logFunc) loggedClose 1 20 size +createSqlPool mkConn size = + createSqlPoolWithConfig + mkConn + (defaultConnectionPoolConfig{connectionPoolConfigSize = size}) --- NOTE: This function is a terrible, ugly hack. It would be much better to --- just clean up monad-logger. +-- | Creates a pool of connections to a SQL database. -- --- FIXME: in a future release, switch over to the new askLoggerIO function --- added in monad-logger 0.3.10. That function was not available at the time --- this code was written. -askLogFunc :: forall m. (MonadUnliftIO m, MonadLogger m) => m LogFunc -askLogFunc = withRunInIO $ \run -> - return $ \a b c d -> run (monadLoggerLog a b c d) +-- @since 2.11.0.0 +createSqlPoolWithConfig + :: forall m backend + . (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend) + => (LogFunc -> IO backend) + -- ^ Function to create a new connection + -> ConnectionPoolConfig + -> m (Pool backend) +createSqlPoolWithConfig mkConn config = do + logFunc <- askLoggerIO + -- Resource pool will swallow any exceptions from close. We want to log + -- them instead. + let + loggedClose :: backend -> IO () + loggedClose backend = + close' backend `UE.catchAny` \e -> do + runLoggingT + (logError $ T.pack $ "Error closing database connection in pool: " ++ show e) + logFunc + UE.throwIO e + liftIO $ + createPool + (mkConn logFunc) + loggedClose + (connectionPoolConfigStripes config) + (connectionPoolConfigIdleTimeout config) + (connectionPoolConfigSize config) -- | Create a connection and run sql queries within it. This function -- automatically closes the connection on it's completion. @@ -284,19 +348,21 @@ -- -- > Migrating: CREATE TABLE "person"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"age" INTEGER NULL) -- > [Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = Person {personName = "John doe", personAge = Just 35}},Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 2}}, entityVal = Person {personName = "Hema", personAge = Just 36}}] --- - withSqlConn - :: (MonadUnliftIO m, MonadLogger m, BackendCompatible SqlBackend backend) + :: forall backend m a + . (MonadUnliftIO m, MonadLoggerIO m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -> (backend -> m a) -> m a withSqlConn open f = do - logFunc <- askLogFunc - withRunInIO $ \run -> bracket - (open logFunc) - close' - (run . f) + logFunc <- askLoggerIO + withRunInIO $ \run -> + UE.bracket + (open logFunc) + close' + (run . f) close' :: (BackendCompatible SqlBackend backend) => backend -> IO () close' conn = do - readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems - connClose $ projectBackend conn + let + backend = projectBackend conn + statementCacheClear $ connStmtMap backend + connClose backend diff --git a/Database/Persist/Sql/Types.hs b/Database/Persist/Sql/Types.hs --- a/Database/Persist/Sql/Types.hs +++ b/Database/Persist/Sql/Types.hs @@ -1,60 +1,99 @@ module Database.Persist.Sql.Types ( module Database.Persist.Sql.Types - , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..) - , Statement (..), LogFunc, InsertSqlResult (..) - , readToUnknown, readToWrite, writeToUnknown - , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend + , SqlBackend + , SqlReadBackend (..) + , SqlWriteBackend (..) + , Statement (..) + , LogFunc + , InsertSqlResult (..) + , readToUnknown + , readToWrite + , writeToUnknown + , SqlBackendCanRead + , SqlBackendCanWrite + , SqlReadT + , SqlWriteT + , IsSqlBackend + , OverflowNatural (..) + , ConnectionPoolConfig (..) ) where -import Control.Exception (Exception) +import Control.Exception (Exception (..)) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.Resource (ResourceT) -import Control.Monad.Trans.Writer (WriterT) import Data.Pool (Pool) import Data.Text (Text) -import Data.Typeable (Typeable) -import Database.Persist.Types +import Data.Time (NominalDiffTime) import Database.Persist.Sql.Types.Internal +import Database.Persist.Types data Column = Column - { cName :: !DBName - , cNull :: !Bool - , cSqlType :: !SqlType - , cDefault :: !(Maybe Text) - , cDefaultConstraintName :: !(Maybe DBName) - , cMaxLen :: !(Maybe Integer) - , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name + { cName :: !FieldNameDB + , cNull :: !Bool + , cSqlType :: !SqlType + , cDefault :: !(Maybe Text) + , cGenerated :: !(Maybe Text) + , cDefaultConstraintName :: !(Maybe ConstraintNameDB) + , cMaxLen :: !(Maybe Integer) + , cReference :: !(Maybe ColumnReference) } deriving (Eq, Ord, Show) -data PersistentSqlException = StatementAlreadyFinalized Text - | Couldn'tGetSQLConnection - deriving (Typeable, Show) +-- | This value specifies how a field references another table. +-- +-- @since 2.11.0.0 +data ColumnReference = ColumnReference + { crTableName :: !EntityNameDB + -- ^ The table name that the + -- + -- @since 2.11.0.0 + , crConstraintName :: !ConstraintNameDB + -- ^ The name of the foreign key constraint. + -- + -- @since 2.11.0.0 + , crFieldCascade :: !FieldCascade + -- ^ Whether or not updates/deletions to the referenced table cascade + -- to this table. + -- + -- @since 2.11.0.0 + } + deriving (Eq, Ord, Show) + +data PersistentSqlException + = StatementAlreadyFinalized Text + | Couldn'tGetSQLConnection + deriving (Show) instance Exception PersistentSqlException type SqlPersistT = ReaderT SqlBackend type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO)) -type Sql = Text - --- Bool indicates if the Sql is safe -type CautiousMigration = [(Bool, Sql)] +type ConnectionPool = Pool SqlBackend --- | A 'Migration' is a four level monad stack consisting of: +-- | Values to configure a pool of database connections. See "Data.Pool" for details. -- --- * @'WriterT' ['Text']@ representing a log of errors in the migrations. --- * @'WriterT' 'CautiousMigration'@ representing a list of migrations to --- run, along with whether or not they are safe. --- * @'ReaderT' 'SqlBackend'@, aka the 'SqlPersistT' transformer for --- database interop. --- * @'IO'@ for arbitrary IO. -type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) () +-- @since 2.11.0.0 +data ConnectionPoolConfig = ConnectionPoolConfig + { connectionPoolConfigStripes :: Int + -- ^ How many stripes to divide the pool into. See "Data.Pool" for details. Default: 1. + , connectionPoolConfigIdleTimeout :: NominalDiffTime + -- ^ How long connections can remain idle before being disposed of, in seconds. Default: 600 + , connectionPoolConfigSize :: Int + -- ^ How many connections should be held in the connection pool. Default: 10 + } + deriving (Show) -type ConnectionPool = Pool SqlBackend +-- TODO: Bad defaults for SQLite maybe? +-- | Initializes a ConnectionPoolConfig with default values. See the documentation of 'ConnectionPoolConfig' for each field's default value. +-- +-- @since 2.11.0.0 +defaultConnectionPoolConfig :: ConnectionPoolConfig +defaultConnectionPoolConfig = ConnectionPoolConfig 1 600 10 + -- $rawSql -- -- Although it covers most of the useful cases, @persistent@'s @@ -106,7 +145,6 @@ -- -- Note that 'rawSql' knows how to replace the double question -- marks @??@ because of the type of the @results@. - -- | A single column (see 'rawSql'). Any 'PersistField' may be -- used here, including 'PersistValue' (which does not do any diff --git a/Database/Persist/Sql/Types/Internal.hs b/Database/Persist/Sql/Types/Internal.hs --- a/Database/Persist/Sql/Types/Internal.hs +++ b/Database/Persist/Sql/Types/Internal.hs @@ -1,6 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +-- | Breaking changes to this module are not reflected in the major version +-- number. Prefer to import from "Database.Persist.Sql" instead. If you neeed +-- something from this module, please file an issue on GitHub. module Database.Persist.Sql.Types.Internal ( HasPersistBackend (..) , IsPersistBackend (..) @@ -20,190 +26,100 @@ , SqlReadT , SqlWriteT , IsSqlBackend + , SqlBackendHooks (..) ) where -import Data.List.NonEmpty (NonEmpty(..)) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Logger (LogSource, LogLevel) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) -import Data.Acquire (Acquire) -import Data.Conduit (ConduitM) -import Data.Int (Int64) -import Data.IORef (IORef) -import Data.Map (Map) -import Data.Monoid ((<>)) -import Data.String (IsString) -import Data.Text (Text) -import Data.Typeable (Typeable) -import Language.Haskell.TH.Syntax (Loc) -import System.Log.FastLogger (LogStr) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Database.Persist.Class - ( HasPersistBackend (..) - , PersistQueryRead, PersistQueryWrite - , PersistStoreRead, PersistStoreWrite - , PersistUniqueRead, PersistUniqueWrite - , BackendCompatible(..) - ) + ( BackendCompatible (..) + , HasPersistBackend (..) + , PersistQueryRead + , PersistQueryWrite + , PersistStoreRead + , PersistStoreWrite + , PersistUniqueRead + , PersistUniqueWrite + ) import Database.Persist.Class.PersistStore (IsPersistBackend (..)) -import Database.Persist.Types - -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () - -data InsertSqlResult = ISRSingle Text - | ISRInsertGet Text Text - | ISRManyKeys Text [PersistValue] - -data Statement = Statement - { stmtFinalize :: IO () - , stmtReset :: IO () - , stmtExecute :: [PersistValue] -> IO Int64 - , stmtQuery :: forall m. MonadIO m - => [PersistValue] - -> Acquire (ConduitM () [PersistValue] m ()) - } - --- | Please refer to the documentation for the database in question for a full --- overview of the semantics of the varying isloation levels -data IsolationLevel = ReadUncommitted - | ReadCommitted - | RepeatableRead - | Serializable - deriving (Show, Eq, Enum, Ord, Bounded) - -makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s -makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of - ReadUncommitted -> "READ UNCOMMITTED" - ReadCommitted -> "READ COMMITTED" - RepeatableRead -> "REPEATABLE READ" - Serializable -> "SERIALIZABLE" - -data SqlBackend = SqlBackend - { connPrepare :: Text -> IO Statement - -- | table name, column names, id name, either 1 or 2 statements to run - , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult - , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) - -- ^ SQL for inserting many rows and returning their primary keys, for - -- backends that support this functioanlity. If 'Nothing', rows will be - -- inserted one-at-a-time using 'connInsertSql'. - , connUpsertSql :: Maybe (EntityDef -> NonEmpty UniqueDef -> Text -> Text) - -- ^ Some databases support performing UPSERT _and_ RETURN entity - -- in a single call. - -- - -- This field when set will be used to generate the UPSERT+RETURN sql given - -- * an entity definition - -- * updates to be run on unique key(s) collision - -- - -- When left as 'Nothing', we find the unique key from entity def before - -- * trying to fetch an entity by said key - -- * perform an update when result found, else issue an insert - -- * return new entity from db - -- - -- @since 2.6 - , connPutManySql :: Maybe (EntityDef -> Int -> Text) - -- ^ Some databases support performing bulk UPSERT, specifically - -- "insert or replace many records" in a single call. - -- - -- This field when set, given - -- * an entity definition - -- * number of records to be inserted - -- should produce a PUT MANY sql with placeholders for records - -- - -- When left as 'Nothing', we default to using 'defaultPutMany'. - -- - -- @since 2.8.1 - , connStmtMap :: IORef (Map Text Statement) - , connClose :: IO () - , connMigrateSql - :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] [(Bool, Text)]) - , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () - , connCommit :: (Text -> IO Statement) -> IO () - , connRollback :: (Text -> IO Statement) -> IO () - , connEscapeName :: DBName -> Text - , connNoLimit :: Text - , connRDBMS :: Text - , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text - , connLogFunc :: LogFunc - , connMaxParams :: Maybe Int - -- ^ Some databases (probably only Sqlite) have a limit on how - -- many question-mark parameters may be used in a statement - -- - -- @since 2.6.1 - , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) - -- ^ Some databases support performing bulk an atomic+bulk INSERT where - -- constraint conflicting entities can replace existing entities. - -- - -- This field when set, given - -- * an entity definition - -- * number of records to be inserted - -- should produce a INSERT sql with placeholders for primary+record fields - -- - -- When left as 'Nothing', we default to using 'defaultRepsertMany'. - -- - -- @since 2.9.0 - } - deriving Typeable -instance HasPersistBackend SqlBackend where - type BaseBackend SqlBackend = SqlBackend - persistBackend = id -instance IsPersistBackend SqlBackend where - mkPersistBackend = id +import Database.Persist.SqlBackend.Internal +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement -- | An SQL backend which can only handle read queries -- -- The constructor was exposed in 2.10.0. -newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } deriving Typeable +newtype SqlReadBackend = SqlReadBackend {unSqlReadBackend :: SqlBackend} + instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend persistBackend = unSqlReadBackend + instance IsPersistBackend SqlReadBackend where mkPersistBackend = SqlReadBackend -- | An SQL backend which can handle read or write queries -- -- The constructor was exposed in 2.10.0 -newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } deriving Typeable +newtype SqlWriteBackend = SqlWriteBackend {unSqlWriteBackend :: SqlBackend} + instance HasPersistBackend SqlWriteBackend where type BaseBackend SqlWriteBackend = SqlBackend persistBackend = unSqlWriteBackend + instance IsPersistBackend SqlWriteBackend where mkPersistBackend = SqlWriteBackend -- | Useful for running a write query against an untagged backend with unknown capabilities. -writeToUnknown :: Monad m => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a +writeToUnknown + :: (Monad m) => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a writeToUnknown ma = do - unknown <- ask - lift . runReaderT ma $ SqlWriteBackend unknown + unknown <- ask + lift . runReaderT ma $ SqlWriteBackend unknown -- | Useful for running a read query against a backend with read and write capabilities. -readToWrite :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlWriteBackend m a +readToWrite + :: (Monad m) => ReaderT SqlReadBackend m a -> ReaderT SqlWriteBackend m a readToWrite ma = do - write <- ask - lift . runReaderT ma . SqlReadBackend $ unSqlWriteBackend write + write <- ask + lift . runReaderT ma . SqlReadBackend $ unSqlWriteBackend write -- | Useful for running a read query against a backend with unknown capabilities. -readToUnknown :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlBackend m a +readToUnknown + :: (Monad m) => ReaderT SqlReadBackend m a -> ReaderT SqlBackend m a readToUnknown ma = do - unknown <- ask - lift . runReaderT ma $ SqlReadBackend unknown + unknown <- ask + lift . runReaderT ma $ SqlReadBackend unknown -- | A constraint synonym which witnesses that a backend is SQL and can run read queries. type SqlBackendCanRead backend = - ( BackendCompatible SqlBackend backend - , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend - ) + ( BackendCompatible SqlBackend backend + , PersistQueryRead backend + , PersistStoreRead backend + , PersistUniqueRead backend + ) + -- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries. type SqlBackendCanWrite backend = - ( SqlBackendCanRead backend - , PersistQueryWrite backend, PersistStoreWrite backend, PersistUniqueWrite backend - ) + ( SqlBackendCanRead backend + , PersistQueryWrite backend + , PersistStoreWrite backend + , PersistUniqueWrite backend + ) + -- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read queries. -type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backend m a +type SqlReadT m a = + forall backend. (SqlBackendCanRead backend) => ReaderT backend m a + -- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read and write queries. -type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a +type SqlWriteT m a = + forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a + -- | A backend which is a wrapper around @SqlBackend@. -type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend) +type IsSqlBackend backend = + ( IsPersistBackend backend + , BaseBackend backend ~ SqlBackend + ) diff --git a/Database/Persist/Sql/Util.hs b/Database/Persist/Sql/Util.hs --- a/Database/Persist/Sql/Util.hs +++ b/Database/Persist/Sql/Util.hs @@ -1,103 +1,215 @@ -module Database.Persist.Sql.Util ( - parseEntityValues - , entityColumnNames - , keyAndEntityColumnNames - , entityColumnCount - , isIdField - , hasCompositeKey - , dbIdColumns - , dbIdColumnsEsc - , dbColumns - , updateFieldDef - , updatePersistValue - , mkUpdateText - , mkUpdateText' - , commaSeparated - , parenWrapped -) where +{-# LANGUAGE ScopedTypeVariables #-} -import Data.Maybe (isJust) -import Data.Monoid ((<>)) +module Database.Persist.Sql.Util + ( parseEntityValues + , keyAndEntityColumnNames + , entityColumnCount + , isIdField + , hasNaturalKey + , hasCompositePrimaryKey + , dbIdColumns + , dbIdColumnsEsc + , dbColumns + , updateFieldDef + , updatePersistValue + , mkUpdateText + , mkUpdateText' + , commaSeparated + , parenWrapped + , mkInsertValues + , mkInsertPlaceholders + , parseExistsResult + ) where + +import Data.ByteString.Char8 (readInteger) +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as T -import Database.Persist ( - Entity(Entity), EntityDef, EntityField, HaskellName(HaskellName) - , PersistEntity, PersistValue - , keyFromValues, fromPersistValues, fieldDB, entityId, entityPrimary - , entityFields, entityKeyFields, fieldHaskell, compositeFields, persistFieldDef - , keyAndEntityFields, toPersistValue, DBName, Update(..), PersistUpdate(..) - , FieldDef - ) -import Database.Persist.Sql.Types (Sql, SqlBackend, connEscapeName) +import Database.Persist + ( Entity (Entity) + , EntityDef + , EntityField + , FieldDef (..) + , FieldNameDB + , FieldNameHS (FieldNameHS) + , PersistEntity (..) + , PersistUpdate (..) + , PersistValue (..) + , Update (..) + , compositeFields + , entityPrimary + , fieldDB + , fieldHaskell + , fromPersistValues + , getEntityFields + , getEntityKeyFields + , keyAndEntityFields + , keyFromValues + , persistFieldDef + , toPersistValue + ) -entityColumnNames :: EntityDef -> SqlBackend -> [Sql] -entityColumnNames ent conn = - (if hasCompositeKey ent - then [] else [connEscapeName conn $ fieldDB (entityId ent)]) - <> map (connEscapeName conn . fieldDB) (entityFields ent) +import Database.Persist.SqlBackend.Internal (SqlBackend (..)) -keyAndEntityColumnNames :: EntityDef -> SqlBackend -> [Sql] -keyAndEntityColumnNames ent conn = map (connEscapeName conn . fieldDB) (keyAndEntityFields ent) +keyAndEntityColumnNames :: EntityDef -> SqlBackend -> NonEmpty Text +keyAndEntityColumnNames ent conn = + fmap (connEscapeFieldName conn . fieldDB) (keyAndEntityFields ent) entityColumnCount :: EntityDef -> Int -entityColumnCount e = length (entityFields e) - + if hasCompositeKey e then 0 else 1 +entityColumnCount e = + length (getEntityFields e) + + if hasNaturalKey e then 0 else 1 -hasCompositeKey :: EntityDef -> Bool -hasCompositeKey = isJust . entityPrimary +-- | Returns 'True' if the entity has a natural key defined with the +-- Primary keyword. +-- +-- A natural key is a key that is inherent to the record, and is part of +-- the actual Haskell record. The opposite of a natural key is a "surrogate +-- key", which is not part of the normal domain object. Automatically +-- generated ID columns are the most common surrogate ID, while an email +-- address is a common natural key. +-- +-- @ +-- User +-- email String +-- name String +-- Primary email +-- +-- Person +-- Id UUID +-- name String +-- +-- Follower +-- name String +-- @ +-- +-- Given these entity definitions, @User@ would return 'True', because the +-- @Primary@ keyword sets the @email@ column to be the primary key. The +-- generated Haskell type would look like this: +-- +-- @ +-- data User = User +-- { userEmail :: String +-- , userName :: String +-- } +-- @ +-- +-- @Person@ would be false. While the @Id@ syntax allows you to define +-- a custom ID type for an entity, the @Id@ column is a surrogate key. +-- +-- The same is true for @Follower@. The automatically generated +-- autoincremented integer primary key is a surrogate key. +-- +-- There's nothing preventing you from defining a @Primary@ definition that +-- refers to a surrogate key. This is totally fine. +-- +-- @since 2.11.0 +hasNaturalKey :: EntityDef -> Bool +hasNaturalKey = + Maybe.isJust . entityPrimary -dbIdColumns :: SqlBackend -> EntityDef -> [Text] -dbIdColumns conn = dbIdColumnsEsc (connEscapeName conn) +-- | Returns 'True' if the provided entity has a custom composite primary +-- key. Composite keys have multiple fields in them. +-- +-- @ +-- User +-- email String +-- name String +-- Primary userId +-- +-- Profile +-- personId PersonId +-- email String +-- Primary personId email +-- +-- Person +-- Id UUID +-- name String +-- +-- Follower +-- name String +-- @ +-- +-- Given these entity definitions, only @Profile@ would return 'True', +-- because it is the only entity with multiple columns in the primary key. +-- @User@ has a single column natural key. @Person@ has a custom single +-- column surrogate key defined with @Id@. And @Follower@ has a default +-- single column surrogate key. +-- +-- @since 2.11.0 +hasCompositePrimaryKey :: EntityDef -> Bool +hasCompositePrimaryKey ed = + case entityPrimary ed of + Just cdef -> + case compositeFields cdef of + (_ :| _ : _) -> + True + _ -> + False + Nothing -> + False -dbIdColumnsEsc :: (DBName -> Text) -> EntityDef -> [Text] -dbIdColumnsEsc esc t = map (esc . fieldDB) $ entityKeyFields t +dbIdColumns :: SqlBackend -> EntityDef -> NonEmpty Text +dbIdColumns conn = dbIdColumnsEsc (connEscapeFieldName conn) -dbColumns :: SqlBackend -> EntityDef -> [Text] -dbColumns conn t = case entityPrimary t of - Just _ -> flds - Nothing -> escapeDB (entityId t) : flds +dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text +dbIdColumnsEsc esc t = fmap (esc . fieldDB) $ getEntityKeyFields t + +dbColumns :: SqlBackend -> EntityDef -> NonEmpty Text +dbColumns conn = + fmap escapeColumn . keyAndEntityFields where - escapeDB = connEscapeName conn . fieldDB - flds = map escapeDB (entityFields t) + escapeColumn = connEscapeFieldName conn . fieldDB -parseEntityValues :: PersistEntity record - => EntityDef -> [PersistValue] -> Either Text (Entity record) +parseEntityValues + :: (PersistEntity record) + => EntityDef -> [PersistValue] -> Either Text (Entity record) parseEntityValues t vals = case entityPrimary t of - Just pdef -> - let pks = map fieldHaskell $ compositeFields pdef - keyvals = map snd . filter ((`elem` pks) . fst) - $ zip (map fieldHaskell $ entityFields t) vals - in fromPersistValuesComposite' keyvals vals - Nothing -> fromPersistValues' vals + Just pdef -> + let + pks = fmap fieldHaskell $ compositeFields pdef + keyvals = + map snd . filter ((`elem` pks) . fst) $ + zip (map fieldHaskell $ getEntityFields t) vals + in + fromPersistValuesComposite' keyvals vals + Nothing -> fromPersistValues' vals where - fromPersistValues' (kpv:xs) = -- oracle returns Double + fromPersistValues' (kpv : xs) = + -- oracle returns Double case fromPersistValues xs of Left e -> Left e Right xs' -> case keyFromValues [kpv] of Left _ -> error $ "fromPersistValues': keyFromValues failed on " ++ show kpv Right k -> Right (Entity k xs') - - fromPersistValues' xs = Left $ pack ("error in fromPersistValues' xs=" ++ show xs) fromPersistValuesComposite' keyvals xs = case fromPersistValues xs of Left e -> Left e Right xs' -> case keyFromValues keyvals of - Left _ -> error "fromPersistValuesComposite': keyFromValues failed" + Left err -> + error $ + "fromPersistValuesComposite': keyFromValues failed with error: " + <> T.unpack err Right key -> Right (Entity key xs') - -isIdField :: PersistEntity record => EntityField record typ -> Bool -isIdField f = fieldHaskell (persistFieldDef f) == HaskellName "Id" +isIdField + :: forall record typ + . (PersistEntity record) + => EntityField record typ + -> Bool +isIdField f = fieldHaskell (persistFieldDef f) == FieldNameHS "Id" -- | Gets the 'FieldDef' for an 'Update'. -updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef :: (PersistEntity v) => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f -updateFieldDef BackendUpdate {} = error "updateFieldDef: did not expect BackendUpdate" +updateFieldDef BackendUpdate{} = error "updateFieldDef: did not expect BackendUpdate" updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v @@ -107,21 +219,88 @@ commaSeparated :: [Text] -> Text commaSeparated = T.intercalate ", " -mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text -mkUpdateText conn = mkUpdateText' (connEscapeName conn) id +mkUpdateText :: (PersistEntity record) => SqlBackend -> Update record -> Text +mkUpdateText conn = mkUpdateText' (connEscapeFieldName conn) id -mkUpdateText' :: PersistEntity record => (DBName -> Text) -> (Text -> Text) -> Update record -> Text +-- TODO: incorporate the table names into a sum type +mkUpdateText' + :: (PersistEntity record) + => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text mkUpdateText' escapeName refColumn x = - case updateUpdate x of - Assign -> n <> "=?" - Add -> T.concat [n, "=", refColumn n, "+?"] - Subtract -> T.concat [n, "=", refColumn n, "-?"] - Multiply -> T.concat [n, "=", refColumn n, "*?"] - Divide -> T.concat [n, "=", refColumn n, "/?"] - BackendSpecificUpdate up -> - error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" + case updateUpdate x of + Assign -> n <> "=?" + Add -> T.concat [n, "=", refColumn n, "+?"] + Subtract -> T.concat [n, "=", refColumn n, "-?"] + Multiply -> T.concat [n, "=", refColumn n, "*?"] + Divide -> T.concat [n, "=", refColumn n, "/?"] + BackendSpecificUpdate up -> + error . T.unpack $ + "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" where n = escapeName . fieldDB . updateFieldDef $ x parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] + +-- | Make a list 'PersistValue' suitable for database inserts. Pairs nicely +-- with the function 'mkInsertPlaceholders'. +-- +-- Does not include generated columns. +-- +-- @since 2.11.0.0 +mkInsertValues + :: (PersistEntity rec) + => rec + -> [PersistValue] +mkInsertValues entity = + Maybe.catMaybes + . zipWith redactGeneratedCol (getEntityFields . entityDef $ Just entity) + $ toPersistFields entity + where + redactGeneratedCol fd pv = case fieldGenerated fd of + Nothing -> + Just pv + Just _ -> + Nothing + +-- | Returns a list of escaped field names and @"?"@ placeholder values for +-- performing inserts. This does not include generated columns. +-- +-- Does not include generated columns. +-- +-- @since 2.11.0.0 +mkInsertPlaceholders + :: EntityDef + -> (FieldNameDB -> Text) + -- ^ An `escape` function + -> [(Text, Text)] +mkInsertPlaceholders ed escape = + Maybe.mapMaybe redactGeneratedCol (getEntityFields ed) + where + redactGeneratedCol fd = case fieldGenerated fd of + Nothing -> + Just (escape (fieldDB fd), "?") + Just _ -> + Nothing + +parseExistsResult :: Maybe [PersistValue] -> Text -> String -> Bool +parseExistsResult mm sql errloc = + case mm of + Just [PersistBool b] -> b -- Postgres + Just [PersistInt64 i] -> i > 0 -- MySQL, SQLite + Just [PersistDouble i] -> (truncate i :: Int64) > 0 -- gb oracle + Just [PersistByteString i] -> case readInteger i of -- gb mssql + Just (ret, "") -> ret > 0 + xs -> error $ "invalid number i[" ++ show i ++ "] xs[" ++ show xs ++ "]" + Just xs -> + error $ + errloc + ++ ": Expected a boolean, int, double, or bytestring; got: " + ++ show xs + ++ " for query: " + ++ show sql + Nothing -> + error $ + errloc + ++ ": Expected a boolean, int, double, or bytestring; got: Nothing for query: " + ++ show sql diff --git a/Database/Persist/SqlBackend.hs b/Database/Persist/SqlBackend.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend.hs @@ -0,0 +1,253 @@ +-- | This module contains types and information necessary for a SQL database. +-- Database support libraries, like @persistent-postgresql@, will be responsible +-- for constructing these values. +module Database.Persist.SqlBackend + ( -- * The type and construction + SqlBackend + , mkSqlBackend + , MkSqlBackendArgs (..) + , SqlBackendHooks + , emptySqlBackendHooks + + -- * Utilities + -- $utilities + + -- ** SqlBackend Getters + , getRDBMS + , getEscapedFieldName + , getEscapedRawName + , getEscapeRawNameFunction + , getConnLimitOffset + , getConnUpsertSql + , getConnVault + , getConnHooks + + -- ** SqlBackend Setters + , setConnMaxParams + , setConnRepsertManySql + , setConnInsertManySql + , setConnUpsertSql + , setConnPutManySql + , setConnVault + , modifyConnVault + , setConnHooks + + -- ** SqlBackendHooks + ) where + +import Control.Monad.Reader +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Vault.Strict (Vault) +import Database.Persist.Class.PersistStore (BackendCompatible (..)) +import Database.Persist.Names +import Database.Persist.SqlBackend.Internal +import qualified Database.Persist.SqlBackend.Internal as SqlBackend + ( SqlBackend (..) + ) +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk + ( MkSqlBackendArgs (..) + ) +import Database.Persist.Types.Base + +-- $utilities +-- +-- The functions exported here are a bit more general than the record accessors. +-- The easiest way to use them is to provide the 'SqlBackend' directly to the +-- function. However, you can also use them in a 'ReaderT' context, and you can +-- even use them with any @backend@ type tht has a @'BackendCompatible' +-- 'SqlBackend' backend@ instance. + +-- | This function can be used directly with a 'SqlBackend' to escape +-- a 'FieldNameDB'. +-- +-- @ +-- let conn :: SqlBackend +-- getEscapedFieldName (FieldNameDB "asdf") conn +-- @ +-- +-- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like +-- 'SqlPersistT': +-- +-- @ +-- query :: SqlPersistM Text +-- query = do +-- field <- getEscapedFieldName (FieldNameDB "asdf") +-- pure field +-- @ +-- +-- @since 2.13.0.0 +getEscapedFieldName + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => FieldNameDB -> m Text +getEscapedFieldName fieldName = do + func <- asks (SqlBackend.connEscapeFieldName . projectBackend) + pure (func fieldName) + +-- | This function can be used directly with a 'SqlBackend' to escape +-- a raw 'Text'. +-- +-- @ +-- let conn :: SqlBackend +-- getEscapedRawName (FieldNameDB "asdf") conn +-- @ +-- +-- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like +-- 'SqlPersistT': +-- +-- @ +-- query :: SqlPersistM Text +-- query = do +-- field <- getEscapedRawName (FieldNameDB "asdf") +-- pure field +-- @ +-- +-- @since 2.13.0.0 +getEscapedRawName + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => Text -> m Text +getEscapedRawName name = do + func <- getEscapeRawNameFunction + pure (func name) + +-- | Return the function for escaping a raw name. +-- +-- @since 2.13.0.0 +getEscapeRawNameFunction + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m (Text -> Text) +getEscapeRawNameFunction = do + asks (SqlBackend.connEscapeRawName . projectBackend) + +-- | Decorate the given SQL query with the @(LIMIT, OFFSET)@ specified. +-- +-- @since 2.13.0.0 +getConnLimitOffset + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => (Int, Int) + -- ^ The @(LIMIT, OFFSET)@ to put on the query. + -> Text + -- ^ The SQL query that the LIMIT/OFFSET clause will be attached to. + -> m Text +getConnLimitOffset limitOffset sql = do + func <- asks (SqlBackend.connLimitOffset . projectBackend) + pure $ func limitOffset sql + +-- | Retrieve the function for generating an upsert statement, if the backend +-- supports it. +-- +-- @since 2.13.0.0 +getConnUpsertSql + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m (Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)) +getConnUpsertSql = do + asks (SqlBackend.connUpsertSql . projectBackend) + +-- | Retrieve the vault from the provided database backend. +-- +-- @since 2.13.3.0 +getConnVault + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m Vault +getConnVault = do + asks (SqlBackend.connVault . projectBackend) + +-- | Retrieve instrumentation hooks from the provided database backend. +-- +-- @since 2.13.3.0 +getConnHooks + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m SqlBackendHooks +getConnHooks = do + asks (SqlBackend.connHooks . projectBackend) + +-- | Get a tag displaying what database the 'SqlBackend' is for. Can be +-- used to differentiate features in downstream libraries for different +-- database backends. +-- @since 2.13.3.0 +getRDBMS + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m Text +getRDBMS = do + asks (SqlBackend.connRDBMS . projectBackend) + +-- | Set the maximum parameters that may be issued in a given SQL query. This +-- should be used only if the database backend have this limitation. +-- +-- @since 2.13.0.0 +setConnMaxParams + :: Int + -> SqlBackend + -> SqlBackend +setConnMaxParams i sb = + sb{connMaxParams = Just i} + +-- | Set the 'connRepsertManySql' field on the 'SqlBackend'. This should only be +-- set by the database backend library. If this is not set, a slow default will +-- be used. +-- +-- @since 2.13.0.0 +setConnRepsertManySql + :: (EntityDef -> Int -> Text) + -> SqlBackend + -> SqlBackend +setConnRepsertManySql mkQuery sb = + sb{connRepsertManySql = Just mkQuery} + +-- | Set the 'connInsertManySql' field on the 'SqlBackend'. This should only be +-- used by the database backend library to provide an efficient implementation +-- of a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnInsertManySql + :: (EntityDef -> [[PersistValue]] -> InsertSqlResult) + -> SqlBackend + -> SqlBackend +setConnInsertManySql mkQuery sb = + sb{connInsertManySql = Just mkQuery} + +-- | Set the 'connUpsertSql' field on the 'SqlBackend'. This should only be used +-- by the database backend library to provide an efficient implementation of +-- a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnUpsertSql + :: (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) + -> SqlBackend + -> SqlBackend +setConnUpsertSql mkQuery sb = + sb{connUpsertSql = Just mkQuery} + +-- | Set the 'connPutManySql field on the 'SqlBackend'. This should only be used +-- by the database backend library to provide an efficient implementation of +-- a bulk insert function. If this is not set, a slow default will be used. +-- +-- @since 2.13.0.0 +setConnPutManySql + :: (EntityDef -> Int -> Text) + -> SqlBackend + -> SqlBackend +setConnPutManySql mkQuery sb = + sb{connPutManySql = Just mkQuery} + +-- | Set the vault on the provided database backend. +-- +-- @since 2.13.0 +setConnVault :: Vault -> SqlBackend -> SqlBackend +setConnVault vault sb = + sb{connVault = vault} + +-- | Modify the vault on the provided database backend. +-- +-- @since 2.13.0 +modifyConnVault :: (Vault -> Vault) -> SqlBackend -> SqlBackend +modifyConnVault f sb = + sb{connVault = f $ connVault sb} + +-- | Set hooks on the provided database backend. +-- +-- @since 2.13.0 +setConnHooks :: SqlBackendHooks -> SqlBackend -> SqlBackend +setConnHooks hooks sb = + sb{connHooks = hooks} diff --git a/Database/Persist/SqlBackend/Internal.hs b/Database/Persist/SqlBackend/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Persist.SqlBackend.Internal where + +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Vault.Strict (Vault) +import qualified Data.Vault.Strict as Vault +import Database.Persist.Class.PersistStore +import Database.Persist.Names +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.StatementCache +import Database.Persist.Types.Base + +-- | A 'SqlBackend' represents a handle or connection to a database. It +-- contains functions and values that allow databases to have more +-- optimized implementations, as well as references that benefit +-- performance and sharing. +-- +-- Instead of using the 'SqlBackend' constructor directly, use the +-- 'mkSqlBackend' function. +-- +-- A 'SqlBackend' is *not* thread-safe. You should not assume that +-- a 'SqlBackend' can be shared among threads and run concurrent queries. +-- This *will* result in problems. Instead, you should create a @'Pool' +-- 'SqlBackend'@, known as a 'ConnectionPool', and pass that around in +-- multi-threaded applications. +-- +-- To run actions in the @persistent@ library, you should use the +-- 'runSqlConn' function. If you're using a multithreaded application, use +-- the 'runSqlPool' function. +data SqlBackend = SqlBackend + { connPrepare :: Text -> IO Statement + -- ^ This function should prepare a 'Statement' in the target database, + -- which should allow for efficient query reuse. + , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult + -- ^ This function generates the SQL and values necessary for + -- performing an insert against the database. + , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) + -- ^ SQL for inserting many rows and returning their primary keys, for + -- backends that support this functionality. If 'Nothing', rows will be + -- inserted one-at-a-time using 'connInsertSql'. + , connUpsertSql + :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) + -- ^ Some databases support performing UPSERT _and_ RETURN entity + -- in a single call. + -- + -- This field when set will be used to generate the UPSERT+RETURN sql given + -- * an entity definition + -- * updates to be run on unique key(s) collision + -- + -- When left as 'Nothing', we find the unique key from entity def before + -- * trying to fetch an entity by said key + -- * perform an update when result found, else issue an insert + -- * return new entity from db + -- + -- @since 2.6 + , connPutManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk UPSERT, specifically + -- "insert or replace many records" in a single call. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a PUT MANY sql with placeholders for records + -- + -- When left as 'Nothing', we default to using 'defaultPutMany'. + -- + -- @since 2.8.1 + , connStmtMap :: StatementCache + -- ^ A reference to the cache of statements. 'Statement's are keyed by + -- the 'Text' queries that generated them. + , connClose :: IO () + -- ^ Close the underlying connection. + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + -- ^ This function returns the migrations required to include the + -- 'EntityDef' parameter in the @['EntityDef']@ database. This might + -- include creating a new table if the entity is not present, or + -- altering an existing table if it is. + , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () + -- ^ A function to begin a transaction for the underlying database. + , connCommit :: (Text -> IO Statement) -> IO () + -- ^ A function to commit a transaction to the underlying database. + , connRollback :: (Text -> IO Statement) -> IO () + -- ^ A function to roll back a transaction on the underlying database. + , connEscapeFieldName :: FieldNameDB -> Text + -- ^ A function to extract and escape the name of the column corresponding + -- to the provided field. + -- + -- @since 2.12.0.0 + , connEscapeTableName :: EntityDef -> Text + -- ^ A function to extract and escape the name of the table corresponding + -- to the provided entity. PostgreSQL uses this to support schemas. + -- + -- @since 2.12.0.0 + , connEscapeRawName :: Text -> Text + -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while + -- PostgreSQL uses quotes, and so on. + -- + -- @since 2.12.0.0 + , connNoLimit :: Text + , connRDBMS :: Text + -- ^ A tag displaying what database the 'SqlBackend' is for. Can be + -- used to differentiate features in downstream libraries for different + -- database backends. + , connLimitOffset :: (Int, Int) -> Text -> Text + -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that + -- LIMIT/OFFSET is problematic for performance, and indexed range + -- queries are the superior way to offer pagination. + , connLogFunc :: LogFunc + -- ^ A log function for the 'SqlBackend' to use. + , connMaxParams :: Maybe Int + -- ^ Some databases (probably only Sqlite) have a limit on how + -- many question-mark parameters may be used in a statement + -- + -- @since 2.6.1 + , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk an atomic+bulk INSERT where + -- constraint conflicting entities can replace existing entities. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a INSERT sql with placeholders for primary+record fields + -- + -- When left as 'Nothing', we default to using 'defaultRepsertMany'. + -- + -- @since 2.9.0 + , connVault :: Vault + -- ^ Carry arbitrary payloads for the connection that + -- may be used to propagate information into hooks. + , connHooks :: SqlBackendHooks + -- ^ Instrumentation hooks that may be used to track the + -- behaviour of a backend. + } + +newtype SqlBackendHooks = SqlBackendHooks + { hookGetStatement :: SqlBackend -> Text -> Statement -> IO Statement + } + +emptySqlBackendHooks :: SqlBackendHooks +emptySqlBackendHooks = + SqlBackendHooks + { hookGetStatement = \_ _ s -> pure s + } + +-- | A function for creating a value of the 'SqlBackend' type. You should prefer +-- to use this instead of the constructor for 'SqlBackend', because default +-- values for this will be provided for new fields on the record when new +-- functionality is added. +-- +-- @since 2.13.0.0 +mkSqlBackend :: MkSqlBackendArgs -> SqlBackend +mkSqlBackend MkSqlBackendArgs{..} = + SqlBackend + { connMaxParams = Nothing + , connRepsertManySql = Nothing + , connPutManySql = Nothing + , connUpsertSql = Nothing + , connInsertManySql = Nothing + , connVault = Vault.empty + , connHooks = emptySqlBackendHooks + , connStmtMap = mkStatementCache $ mkSimpleStatementCache connStmtMap + , .. + } + +instance HasPersistBackend SqlBackend where + type BaseBackend SqlBackend = SqlBackend + persistBackend = id + +instance IsPersistBackend SqlBackend where + mkPersistBackend = id diff --git a/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs b/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs @@ -0,0 +1,9 @@ +module Database.Persist.SqlBackend.Internal.InsertSqlResult where + +import Data.Text (Text) +import Database.Persist.Types.Base (PersistValue) + +data InsertSqlResult + = ISRSingle Text + | ISRInsertGet Text Text + | ISRManyKeys Text [PersistValue] diff --git a/Database/Persist/SqlBackend/Internal/IsolationLevel.hs b/Database/Persist/SqlBackend/Internal/IsolationLevel.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal/IsolationLevel.hs @@ -0,0 +1,20 @@ +module Database.Persist.SqlBackend.Internal.IsolationLevel where + +import Data.String (IsString (..)) + +-- | Please refer to the documentation for the database in question for a full +-- overview of the semantics of the varying isolation levels +data IsolationLevel + = ReadUncommitted + | ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Enum, Ord, Bounded) + +makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s +makeIsolationLevelStatement l = + "SET TRANSACTION ISOLATION LEVEL " <> case l of + ReadUncommitted -> "READ UNCOMMITTED" + ReadCommitted -> "READ COMMITTED" + RepeatableRead -> "REPEATABLE READ" + Serializable -> "SERIALIZABLE" diff --git a/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs b/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE RankNTypes #-} + +module Database.Persist.SqlBackend.Internal.MkSqlBackend where + +import Control.Monad.Logger (Loc, LogLevel, LogSource, LogStr) +import Data.IORef (IORef) +import Data.Map (Map) +import Data.Text (Text) +import Database.Persist.Names +import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.Types.Base + +-- | This type shares many of the same field names as the 'SqlBackend' type. +-- It's useful for library authors to use this when migrating from using the +-- 'SqlBackend' constructor directly to the 'mkSqlBackend' function. +-- +-- This type will only contain required fields for constructing a 'SqlBackend'. +-- For fields that aren't present on this record, you'll want to use the various +-- @set@ functions or +-- +-- @since 2.13.0.0 +data MkSqlBackendArgs = MkSqlBackendArgs + { connPrepare :: Text -> IO Statement + -- ^ This function should prepare a 'Statement' in the target database, + -- which should allow for efficient query reuse. + , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult + -- ^ This function generates the SQL and values necessary for + -- performing an insert against the database. + , connStmtMap :: IORef (Map Text Statement) + -- ^ A reference to the cache of statements. 'Statement's are keyed by + -- the 'Text' queries that generated them. + , connClose :: IO () + -- ^ Close the underlying connection. + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + -- ^ This function returns the migrations required to include the + -- 'EntityDef' parameter in the @['EntityDef']@ database. This might + -- include creating a new table if the entity is not present, or + -- altering an existing table if it is. + , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () + -- ^ A function to begin a transaction for the underlying database. + , connCommit :: (Text -> IO Statement) -> IO () + -- ^ A function to commit a transaction to the underlying database. + , connRollback :: (Text -> IO Statement) -> IO () + -- ^ A function to roll back a transaction on the underlying database. + , connEscapeFieldName :: FieldNameDB -> Text + -- ^ A function to extract and escape the name of the column corresponding + -- to the provided field. + -- + -- @since 2.12.0.0 + , connEscapeTableName :: EntityDef -> Text + -- ^ A function to extract and escape the name of the table corresponding + -- to the provided entity. PostgreSQL uses this to support schemas. + -- + -- @since 2.12.0.0 + , connEscapeRawName :: Text -> Text + -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while + -- PostgreSQL uses quotes, and so on. + -- + -- @since 2.12.0.0 + , connNoLimit :: Text + , connRDBMS :: Text + -- ^ A tag displaying what database the 'SqlBackend' is for. Can be + -- used to differentiate features in downstream libraries for different + -- database backends. + , connLimitOffset :: (Int, Int) -> Text -> Text + -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that + -- LIMIT/OFFSET is problematic for performance, and indexed range + -- queries are the superior way to offer pagination. + , connLogFunc :: LogFunc + -- ^ A log function for the 'SqlBackend' to use. + } + +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () diff --git a/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs b/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs @@ -0,0 +1,22 @@ +module Database.Persist.SqlBackend.Internal.SqlPoolHooks + ( SqlPoolHooks (..) + ) where + +import Control.Exception (SomeException) +import Database.Persist.SqlBackend.Internal.IsolationLevel + +-- | A set of hooks that may be used to alter the behaviour +-- of @runSqlPoolWithExtensibleHooks@ in a backwards-compatible +-- fashion. +data SqlPoolHooks m backend = SqlPoolHooks + { alterBackend :: backend -> m backend + -- ^ Alter the backend prior to executing any actions with it. + , runBefore :: backend -> Maybe IsolationLevel -> m () + -- ^ Run this action immediately before the action is performed. + , runAfter :: backend -> Maybe IsolationLevel -> m () + -- ^ Run this action immediately after the action is completed. + , runOnException :: backend -> Maybe IsolationLevel -> SomeException -> m () + -- ^ This action is performed when an exception is received. The + -- exception is provided as a convenience - it is rethrown once this + -- cleanup function is complete. + } diff --git a/Database/Persist/SqlBackend/Internal/Statement.hs b/Database/Persist/SqlBackend/Internal/Statement.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal/Statement.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE RankNTypes #-} + +module Database.Persist.SqlBackend.Internal.Statement where + +import Conduit +import Data.Acquire +import Data.Int +import Database.Persist.Types.Base + +-- | A 'Statement' is a representation of a database query that has been +-- prepared and stored on the server side. +data Statement = Statement + { stmtFinalize :: IO () + , stmtReset :: IO () + , stmtExecute :: [PersistValue] -> IO Int64 + , stmtQuery + :: forall m + . (MonadIO m) + => [PersistValue] + -> Acquire (ConduitM () [PersistValue] m ()) + } diff --git a/Database/Persist/SqlBackend/Internal/StatementCache.hs b/Database/Persist/SqlBackend/Internal/StatementCache.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/Internal/StatementCache.hs @@ -0,0 +1,24 @@ +module Database.Persist.SqlBackend.Internal.StatementCache where + +import Data.Text (Text) +import Database.Persist.SqlBackend.Internal.Statement + +-- | A statement cache used to lookup statements that have already been prepared +-- for a given query. +-- +-- @since 2.13.3 +data StatementCache = StatementCache + { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) + , statementCacheInsert :: StatementCacheKey -> Statement -> IO () + , statementCacheClear :: IO () + , statementCacheSize :: IO Int + } + +newtype StatementCacheKey = StatementCacheKey {cacheKey :: Text} + +-- Wrapping around this to allow for more efficient keying mechanisms +-- in the future, perhaps. + +-- | Construct a `StatementCacheKey` from a raw SQL query. +mkCacheKeyFromQuery :: Text -> StatementCacheKey +mkCacheKeyFromQuery = StatementCacheKey diff --git a/Database/Persist/SqlBackend/SqlPoolHooks.hs b/Database/Persist/SqlBackend/SqlPoolHooks.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/SqlPoolHooks.hs @@ -0,0 +1,127 @@ +module Database.Persist.SqlBackend.SqlPoolHooks + ( SqlPoolHooks + , defaultSqlPoolHooks + , getAlterBackend + , modifyAlterBackend + , setAlterBackend + , getRunBefore + , modifyRunBefore + , setRunBefore + , getRunAfter + , modifyRunAfter + , setRunAfter + , getRunOnException + ) +where + +import Control.Exception +import Control.Monad.IO.Class +import Database.Persist.Class.PersistStore +import Database.Persist.Sql.Raw +import Database.Persist.SqlBackend.Internal +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.SqlBackend.Internal.SqlPoolHooks + +-- | Lifecycle hooks that may be altered to extend SQL pool behavior +-- in a backwards compatible fashion. +-- +-- By default, the hooks have the following semantics: +-- +-- - 'alterBackend' has no effect +-- - 'runBefore' begins a transaction +-- - 'runAfter' commits the current transaction +-- - 'runOnException' rolls back the current transaction +-- +-- @since 2.13.3.0 +defaultSqlPoolHooks + :: (MonadIO m, BackendCompatible SqlBackend backend) => SqlPoolHooks m backend +defaultSqlPoolHooks = + SqlPoolHooks + { alterBackend = pure + , runBefore = \conn mi -> do + let + sqlBackend = projectBackend conn + let + getter = getStmtConn sqlBackend + liftIO $ connBegin sqlBackend getter mi + , runAfter = \conn _ -> do + let + sqlBackend = projectBackend conn + let + getter = getStmtConn sqlBackend + liftIO $ connCommit sqlBackend getter + , runOnException = \conn _ _ -> do + let + sqlBackend = projectBackend conn + let + getter = getStmtConn sqlBackend + liftIO $ connRollback sqlBackend getter + } + +getAlterBackend :: SqlPoolHooks m backend -> (backend -> m backend) +getAlterBackend = alterBackend + +modifyAlterBackend + :: SqlPoolHooks m backend + -> ((backend -> m backend) -> (backend -> m backend)) + -> SqlPoolHooks m backend +modifyAlterBackend hooks f = hooks{alterBackend = f $ alterBackend hooks} + +setAlterBackend + :: SqlPoolHooks m backend -> (backend -> m backend) -> SqlPoolHooks m backend +setAlterBackend hooks f = hooks{alterBackend = f} + +getRunBefore + :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) +getRunBefore = runBefore + +modifyRunBefore + :: SqlPoolHooks m backend + -> ( (backend -> Maybe IsolationLevel -> m ()) + -> (backend -> Maybe IsolationLevel -> m ()) + ) + -> SqlPoolHooks m backend +modifyRunBefore hooks f = hooks{runBefore = f $ runBefore hooks} + +setRunBefore + :: SqlPoolHooks m backend + -> (backend -> Maybe IsolationLevel -> m ()) + -> SqlPoolHooks m backend +setRunBefore h f = h{runBefore = f} + +getRunAfter + :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) +getRunAfter = runAfter + +modifyRunAfter + :: SqlPoolHooks m backend + -> ( (backend -> Maybe IsolationLevel -> m ()) + -> (backend -> Maybe IsolationLevel -> m ()) + ) + -> SqlPoolHooks m backend +modifyRunAfter hooks f = hooks{runAfter = f $ runAfter hooks} + +setRunAfter + :: SqlPoolHooks m backend + -> (backend -> Maybe IsolationLevel -> m ()) + -> SqlPoolHooks m backend +setRunAfter hooks f = hooks{runAfter = f} + +getRunOnException + :: SqlPoolHooks m backend + -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) +getRunOnException = runOnException + +modifyRunOnException + :: SqlPoolHooks m backend + -> ( (backend -> Maybe IsolationLevel -> SomeException -> m ()) + -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) + ) + -> SqlPoolHooks m backend +modifyRunOnException hooks f = hooks{runOnException = f $ runOnException hooks} + +setRunOnException + :: SqlPoolHooks m backend + -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) + -> SqlPoolHooks m backend +setRunOnException hooks f = hooks{runOnException = f} diff --git a/Database/Persist/SqlBackend/StatementCache.hs b/Database/Persist/SqlBackend/StatementCache.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/SqlBackend/StatementCache.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE RecordWildCards #-} + +module Database.Persist.SqlBackend.StatementCache + ( StatementCache + , StatementCacheKey + , mkCacheKeyFromQuery + , MkStatementCache (..) + , mkSimpleStatementCache + , mkStatementCache + ) where + +import Data.Foldable +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.StatementCache + +-- | Configuration parameters for creating a custom statement cache +-- +-- @since 2.13.3 +data MkStatementCache = MkStatementCache + { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) + -- ^ Retrieve a statement from the cache, or return nothing if it is not found. + -- + -- @since 2.13.3 + , statementCacheInsert :: StatementCacheKey -> Statement -> IO () + -- ^ Put a new statement into the cache. An immediate lookup of + -- the statement MUST return the inserted statement for the given + -- cache key. Depending on the implementation, the statement cache MAY + -- choose to evict other statements from the cache within this function. + -- + -- @since 2.13.3 + , statementCacheClear :: IO () + -- ^ Remove all statements from the cache. Implementations of this + -- should be sure to call `stmtFinalize` on all statements removed + -- from the cache. + -- + -- @since 2.13.3 + , statementCacheSize :: IO Int + -- ^ Get the current size of the cache. + -- + -- @since 2.13.3 + } + +-- | Make a simple statement cache that will cache statements if they are not currently cached. +-- +-- @since 2.13.3 +mkSimpleStatementCache :: IORef (Map Text Statement) -> MkStatementCache +mkSimpleStatementCache stmtMap = + MkStatementCache + { statementCacheLookup = \sql -> Map.lookup (cacheKey sql) <$> readIORef stmtMap + , statementCacheInsert = \sql stmt -> + modifyIORef' stmtMap (Map.insert (cacheKey sql) stmt) + , statementCacheClear = do + oldStatements <- + atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) + traverse_ stmtFinalize oldStatements + , statementCacheSize = Map.size <$> readIORef stmtMap + } + +-- | Create a statement cache. +-- +-- @since 2.13.0 +mkStatementCache :: MkStatementCache -> StatementCache +mkStatementCache MkStatementCache{..} = StatementCache{..} diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/TH.hs @@ -0,0 +1,52 @@ +-- | This module provides the tools for defining your database schema and using +-- it to generate Haskell data types and migrations. +-- +-- For documentation on the domain specific language used for defining database +-- models, see "Database.Persist.Quasi". +module Database.Persist.TH + ( -- * Parse entity defs + persistWith + , persistUpperCase + , persistLowerCase + , persistFileWith + , persistManyFileWith + + -- * Turn @EntityDef@s into types + , mkPersist + , mkPersistWith + + -- ** Configuring Entity Definition + , MkPersistSettings + , mkPersistSettings + , sqlSettings + + -- *** Record Fields (for update/viewing settings) + , mpsBackend + , mpsGeneric + , mpsPrefixFields + , mpsFieldLabelModifier + , mpsAvoidHsKeyword + , mpsConstraintLabelModifier + , mpsEntityHaddocks + , mpsEntityJSON + , mpsGenerateLenses + , mpsDeriveInstances + , mpsCamelCaseCompositeKeySelector + , EntityJSON (..) + + -- ** Implicit ID Columns + , ImplicitIdDef + , setImplicitIdDef + + -- * Various other TH functions + , mkMigrate + , migrateModels + , discoverEntities + , mkEntityDefList + , share + , derivePersistField + , derivePersistFieldJSON + , persistFieldFromEntity + ) where + +import Database.Persist.TH.Internal diff --git a/Database/Persist/TH/Internal.hs b/Database/Persist/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/TH/Internal.hs @@ -0,0 +1,4034 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module provides the tools for defining your database schema and using +-- it to generate Haskell data types and migrations. +-- +-- For documentation on the domain specific language used for defining database +-- models, see "Database.Persist.Quasi". +module Database.Persist.TH.Internal + ( -- * Parse entity defs + persistWith + , persistUpperCase + , persistLowerCase + , persistFileWith + , persistManyFileWith + + -- * Turn @EntityDef@s into types + , mkPersist + , mkPersistWith + + -- ** Configuring Entity Definition + , MkPersistSettings + , mkPersistSettings + , sqlSettings + + -- *** Record Fields (for update/viewing settings) + , mpsBackend + , mpsGeneric + , mpsPrefixFields + , mpsFieldLabelModifier + , mpsAvoidHsKeyword + , mpsConstraintLabelModifier + , mpsEntityHaddocks + , mpsEntityJSON + , mpsGenerateLenses + , mpsDeriveInstances + , mpsCamelCaseCompositeKeySelector + , EntityJSON (..) + + -- ** Implicit ID Columns + , ImplicitIdDef + , setImplicitIdDef + + -- * Various other TH functions + , mkMigrate + , migrateModels + , discoverEntities + , mkEntityDefList + , share + , derivePersistField + , derivePersistFieldJSON + , persistFieldFromEntity + + -- * Internal + , lensPTH + , parseReferences + , embedEntityDefs + , fieldError + , AtLeastOneUniqueKey (..) + , OnlyOneUniqueKey (..) + , pkNewtype + ) where + +-- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code +-- It's highly recommended to check the diff between master and your PR's generated code. + +import Prelude hiding (concat, exp, splitAt, take, (++)) + +import Control.Monad +import Data.Aeson + ( FromJSON (..) + , ToJSON (..) + , eitherDecodeStrict' + , object + , withObject + , (.:) + , (.:?) + , (.=) + ) +import Data.Functor.Apply ((<.>)) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as Key +#endif +import qualified Data.ByteString as BS +import Data.Char (toLower, toUpper) +import Data.Coerce +import Data.Data (Data) +import Data.Either +import qualified Data.HashMap.Strict as HM +import Data.Int (Int64) +import Data.Ix (Ix) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) +import Data.Proxy (Proxy (Proxy)) +import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import GHC.TypeLits +import Instances.TH.Lift () + +-- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` +-- instance on pre-1.2.4 versions of `text` +import Data.Foldable (asum, toList, traverse_) +import qualified Data.Set as Set +import Language.Haskell.TH.Lib + ( appT + , conE + , conK + , conT + , litT + , strTyLit + , varE + , varP + , varT + ) +#if MIN_VERSION_template_haskell(2,21,0) +import Language.Haskell.TH.Lib (defaultBndrFlag) +#endif +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +import Web.PathPieces (PathPiece (..)) + +import Database.Persist +import Database.Persist.Class.PersistEntity +import Database.Persist.Quasi +import Database.Persist.Quasi.Internal +import Database.Persist.Quasi.PersistSettings +import Database.Persist.Sql + ( Migration + , PersistFieldSql + , SqlBackend + , migrate + , sqlType + ) + +import Database.Persist.EntityDef.Internal (EntityDef (..)) +import Database.Persist.ImplicitIdDef (autoIncrementingInteger) +import Database.Persist.ImplicitIdDef.Internal + +#if MIN_VERSION_template_haskell(2,18,0) +conp :: Name -> [Pat] -> Pat +conp name pats = ConP name [] pats +#else +conp :: Name -> [Pat] -> Pat +conp = ConP +#endif + +-- | Converts a quasi-quoted syntax into a list of entity definitions, to be +-- used as input to the template haskell generation code (mkPersist). +persistWith :: PersistSettings -> QuasiQuoter +persistWith ps = + QuasiQuoter + { quoteExp = \exp -> do + loc <- location + parseReferences ps [(Just $ sourceLocFromTHLoc loc, pack exp)] + , quotePat = + error "persistWith can't be used as pattern" + , quoteType = + error "persistWith can't be used as type" + , quoteDec = + error "persistWith can't be used as declaration" + } + +-- | Apply 'persistWith' to 'upperCaseSettings'. +persistUpperCase :: QuasiQuoter +persistUpperCase = persistWith upperCaseSettings + +-- | Apply 'persistWith' to 'lowerCaseSettings'. +persistLowerCase :: QuasiQuoter +persistLowerCase = persistWith lowerCaseSettings + +-- | Same as 'persistWith', but uses an external file instead of a +-- quasiquotation. The recommended file extension is @.persistentmodels@. +persistFileWith :: PersistSettings -> FilePath -> Q Exp +persistFileWith ps fp = persistManyFileWith ps [fp] + +-- | Same as 'persistFileWith', but uses several external files instead of +-- one. Splitting your Persistent definitions into multiple modules can +-- potentially dramatically speed up compile times. +-- +-- The recommended file extension is @.persistentmodels@. +-- +-- ==== __Examples__ +-- +-- Split your Persistent definitions into multiple files (@models1@, @models2@), +-- then create a new module for each new file and run 'mkPersist' there: +-- +-- @ +-- -- Model1.hs +-- 'share' +-- ['mkPersist' 'sqlSettings'] +-- $('persistFileWith' 'lowerCaseSettings' "models1") +-- @ +-- @ +-- -- Model2.hs +-- 'share' +-- ['mkPersist' 'sqlSettings'] +-- $('persistFileWith' 'lowerCaseSettings' "models2") +-- @ +-- +-- Use 'persistManyFileWith' to create your migrations: +-- +-- @ +-- -- Migrate.hs +-- 'mkMigrate' "migrateAll" +-- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) +-- @ +-- +-- Tip: To get the same import behavior as if you were declaring all your models in +-- one file, import your new files @as Name@ into another file, then export @module Name@. +-- +-- This approach may be used in the future to reduce memory usage during compilation, +-- but so far we've only seen mild reductions. +-- +-- See and +-- for more details. +-- +-- @since 2.5.4 +persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp +persistManyFileWith ps fps = do + mapM_ qAddDependentFile fps + ss <- mapM (\fp -> (fp,) <$> (qRunIO . getFileContents) fp) fps + parseReferences ps (map (\(fp, content) -> (Just $ sourceLoc fp, content)) ss) + where + sourceLoc path = SourceLoc{locFile = T.pack path, locStartLine = 1, locStartCol = 1} + +getFileContents :: FilePath -> IO Text +getFileContents = fmap decodeUtf8 . BS.readFile + +-- | Takes a list of (potentially) independently defined entities and properly +-- links all foreign keys to reference the right 'EntityDef', tying the knot +-- between entities. +-- +-- Allows users to define entities indepedently or in separate modules and then +-- fix the cross-references between them at runtime to create a 'Migration'. +-- +-- @since 2.7.2 +embedEntityDefs + :: [EntityDef] + -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' + -- call. + -- + -- @since 2.13.0.0 + -> [UnboundEntityDef] + -> [UnboundEntityDef] +embedEntityDefs eds = snd . embedEntityDefsMap eds + +embedEntityDefsMap + :: [EntityDef] + -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' + -- call. + -- + -- @since 2.13.0.0 + -> [UnboundEntityDef] + -> (EmbedEntityMap, [UnboundEntityDef]) +embedEntityDefsMap existingEnts rawEnts = + (embedEntityMap, noCycleEnts) + where + noCycleEnts = entsWithEmbeds + embedEntityMap = constructEmbedEntityMap entsWithEmbeds + entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts) + setEmbedEntity ubEnt = + let + ent = unboundEntityDef ubEnt + in + ubEnt + { unboundEntityDef = + overEntityFields + (fmap (setEmbedField (entityHaskell ent) embedEntityMap)) + ent + } + +-- | Calls 'parse' to Quasi.parse individual entities in isolation +-- afterwards, sets references to other entities +-- +-- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@ +-- instead of @['EntityDef']@. +-- +-- @since 2.16.0.0 +parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp +parseReferences ps s = do + let + (warnings, res) = parse ps s + traverse_ (reportWarning . parserWarningMessage) $ warnings + case res of + Left errs -> fail $ renderErrors errs + Right r -> lift r + +preprocessUnboundDefs + :: [EntityDef] + -> [UnboundEntityDef] + -> (M.Map EntityNameHS (), [UnboundEntityDef]) +preprocessUnboundDefs preexistingEntities unboundDefs = + (embedEntityMap, noCycleEnts) + where + (embedEntityMap, noCycleEnts) = + embedEntityDefsMap preexistingEntities unboundDefs + +liftAndFixKeys + :: MkPersistSettings + -> M.Map EntityNameHS a + -> EntityMap + -> UnboundEntityDef + -> Q Exp +liftAndFixKeys mps emEntities entityMap unboundEnt = + let + ent = + unboundEntityDef unboundEnt + fields = + getUnboundFieldDefs unboundEnt + in + [| + ent + { entityFields = + $(ListE <$> traverse combinedFixFieldDef fields) + , entityId = + $(fixPrimarySpec mps unboundEnt) + , entityForeigns = + $(fixUnboundForeignDefs (unboundForeignDefs unboundEnt)) + } + |] + where + fixUnboundForeignDefs + :: [UnboundForeignDef] + -> Q Exp + fixUnboundForeignDefs fdefs = + fmap ListE $ forM fdefs fixUnboundForeignDef + where + fixUnboundForeignDef UnboundForeignDef{..} = + [| + unboundForeignDef + { foreignFields = + $(lift fixForeignFields) + , foreignNullable = + $(lift fixForeignNullable) + , foreignRefTableDBName = + $(lift fixForeignRefTableDBName) + } + |] + where + fixForeignRefTableDBName = + entityDB (unboundEntityDef parentDef) + foreignFieldNames = + case unboundForeignFields of + FieldListImpliedId ffns -> + ffns + FieldListHasReferences references -> + fmap ffrSourceField references + parentDef = + case M.lookup parentTableName entityMap of + Nothing -> + error $ + mconcat + [ "Foreign table not defined: " + , show parentTableName + ] + Just a -> + a + parentTableName = + foreignRefTableHaskell unboundForeignDef + fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)] + fixForeignFields = + case unboundForeignFields of + FieldListImpliedId ffns -> + mkReferences $ toList ffns + FieldListHasReferences references -> + toList $ fmap convReferences references + where + -- in this case, we're up against the implied ID of the parent + -- dodgy assumption: columns are listed in the right order. we + -- can't check this any more clearly right now. + mkReferences fieldNames + | length fieldNames /= length parentKeyFieldNames = + error $ + mconcat + [ "Foreign reference needs to have the same number " + , "of fields as the target table." + , "\n Table : " + , show (getUnboundEntityNameHS unboundEnt) + , "\n Foreign Table: " + , show parentTableName + , "\n Fields : " + , show fieldNames + , "\n Parent fields: " + , show (fmap fst parentKeyFieldNames) + , "\n\nYou can use the References keyword to fix this." + ] + | otherwise = + zip (fmap (withDbName fieldStore) fieldNames) (toList parentKeyFieldNames) + where + parentKeyFieldNames + :: NonEmpty (FieldNameHS, FieldNameDB) + parentKeyFieldNames = + case unboundPrimarySpec parentDef of + NaturalKey ucd -> + fmap (withDbName parentFieldStore) (unboundCompositeCols ucd) + SurrogateKey uid -> + pure (FieldNameHS "Id", unboundIdDBName uid) + DefaultKey dbName -> + pure (FieldNameHS "Id", dbName) + withDbName store fieldNameHS = + ( fieldNameHS + , findDBName store fieldNameHS + ) + convReferences + :: ForeignFieldReference + -> (ForeignFieldDef, ForeignFieldDef) + convReferences ForeignFieldReference{..} = + ( withDbName fieldStore ffrSourceField + , withDbName parentFieldStore ffrTargetField + ) + fixForeignNullable = + all ((NotNullable /=) . isForeignNullable) foreignFieldNames + where + isForeignNullable fieldNameHS = + case getFieldDef fieldNameHS fieldStore of + Nothing -> + error "Field name not present in map" + Just a -> + isUnboundFieldNullable a + + fieldStore = + mkFieldStore unboundEnt + parentFieldStore = + mkFieldStore parentDef + findDBName store fieldNameHS = + case getFieldDBName fieldNameHS store of + Nothing -> + error $ + mconcat + [ "findDBName: failed to fix dbname for: " + , show fieldNameHS + ] + Just a -> + a + + combinedFixFieldDef :: UnboundFieldDef -> Q Exp + combinedFixFieldDef ufd@UnboundFieldDef{..} = + [| + FieldDef + { fieldHaskell = + unboundFieldNameHS + , fieldDB = + unboundFieldNameDB + , fieldType = + unboundFieldType + , fieldSqlType = + $(sqlTyp') + , fieldAttrs = + unboundFieldAttrs + , fieldStrict = + unboundFieldStrict + , fieldReference = + $(fieldRef') + , fieldCascade = + unboundFieldCascade + , fieldComments = + unboundFieldComments + , fieldGenerated = + unboundFieldGenerated + , fieldIsImplicitIdColumn = + False + } + |] + where + sqlTypeExp = + getSqlType emEntities entityMap ufd + FieldDef _x _ _ _ _ _ _ _ _ _ _ = + error "need to update this record wildcard match" + (fieldRef', sqlTyp') = + case extractForeignRef entityMap ufd of + Just targetTable -> + let + targetTableQualified = + fromMaybe targetTable (guessFieldReferenceQualified ufd) + in + ( lift (ForeignRef targetTable) + , liftSqlTypeExp (SqlTypeReference targetTableQualified) + ) + Nothing -> + (lift NoReference, liftSqlTypeExp sqlTypeExp) + +data FieldStore + = FieldStore + { fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef + , fieldStoreId :: Maybe FieldNameDB + , fieldStoreEntity :: UnboundEntityDef + } + +mkFieldStore :: UnboundEntityDef -> FieldStore +mkFieldStore ued = + FieldStore + { fieldStoreEntity = ued + , fieldStoreMap = + M.fromList + $ fmap + ( \ufd -> + ( unboundFieldNameHS ufd + , ufd + ) + ) + $ getUnboundFieldDefs + $ ued + , fieldStoreId = + case unboundPrimarySpec ued of + NaturalKey _ -> + Nothing + SurrogateKey fd -> + Just $ unboundIdDBName fd + DefaultKey n -> + Just n + } + +getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB +getFieldDBName name fs + | FieldNameHS "Id" == name = + fieldStoreId fs + | otherwise = + unboundFieldNameDB <$> getFieldDef name fs + +getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef +getFieldDef fieldNameHS fs = + M.lookup fieldNameHS (fieldStoreMap fs) + +extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS +extractForeignRef entityMap fieldDef = do + refName <- guessFieldReference fieldDef + ent <- M.lookup refName entityMap + pure $ entityHaskell $ unboundEntityDef ent + +guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS +guessFieldReference = guessReference . unboundFieldType + +guessReference :: FieldType -> Maybe EntityNameHS +guessReference ft = + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] + +guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS +guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType + +guessReferenceQualified :: FieldType -> Maybe EntityNameHS +guessReferenceQualified ft = + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] + +mkDefaultKey + :: MkPersistSettings + -> FieldNameDB + -> EntityNameHS + -> FieldDef +mkDefaultKey mps pk unboundHaskellName = + let + iid = + mpsImplicitIdDef mps + in + maybe id addFieldAttr (FieldAttrDefault <$> iidDefault iid) $ + maybe id addFieldAttr (FieldAttrMaxlen <$> iidMaxLen iid) $ + mkAutoIdField' pk unboundHaskellName (iidFieldSqlType iid) + +fixPrimarySpec + :: MkPersistSettings + -> UnboundEntityDef + -> Q Exp +fixPrimarySpec mps unboundEnt = do + case unboundPrimarySpec unboundEnt of + DefaultKey pk -> + lift $ + EntityIdField $ + mkDefaultKey mps pk unboundHaskellName + SurrogateKey uid -> do + let + entNameHS = + getUnboundEntityNameHS unboundEnt + fieldTyp = + fromMaybe (mkKeyConType entNameHS) (unboundIdType uid) + [| + EntityIdField + FieldDef + { fieldHaskell = + FieldNameHS "Id" + , fieldDB = + $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid)) + , fieldType = + $(lift fieldTyp) + , fieldSqlType = + $(liftSqlTypeExp (SqlTypeExp fieldTyp)) + , fieldStrict = + False + , fieldReference = + ForeignRef entNameHS + , fieldAttrs = + unboundIdAttrs uid + , fieldComments = + Nothing + , fieldCascade = unboundIdCascade uid + , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True + } + |] + NaturalKey ucd -> + [|EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd)|] + where + unboundHaskellName = + getUnboundEntityNameHS unboundEnt + +bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp +bindCompositeDef ued ucd = do + fieldDefs <- + fmap ListE $ forM (toList $ unboundCompositeCols ucd) $ \col -> + mkLookupEntityField ued col + [| + CompositeDef + { compositeFields = + NEL.fromList $(pure fieldDefs) + , compositeAttrs = + $(lift $ unboundCompositeAttrs ucd) + } + |] + +getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp +getSqlType emEntities entityMap field = + maybe + (defaultSqlTypeExp emEntities entityMap field) + (SqlType' . SqlOther) + (listToMaybe $ mapMaybe attrSqlType $ unboundFieldAttrs field) + +-- In the case of embedding, there won't be any datatype created yet. +-- We just use SqlString, as the data will be serialized to JSON. +defaultSqlTypeExp + :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp +defaultSqlTypeExp emEntities entityMap field = + case mEmbedded emEntities ftype of + Right _ -> + SqlType' SqlString + Left (Just (FTKeyCon ty)) -> + SqlTypeExp (FTTypeCon Nothing ty) + Left Nothing -> + case extractForeignRef entityMap field of + Just refName -> + case M.lookup refName entityMap of + Nothing -> + -- error $ mconcat + -- [ "Failed to find model: " + -- , show refName + -- , " in entity list: \n" + -- ] + -- <> (unlines $ map show $ M.keys $ entityMap) + -- going to assume that it's fine, will reify it out + -- right later anyway) + SqlTypeExp ftype + -- A ForeignRef is blindly set to an Int64 in setEmbedField + -- correct that now + Just _ -> + SqlTypeReference refName + _ -> + case ftype of + -- In the case of lists, we always serialize to a string + -- value (via JSON). + -- + -- Normally, this would be determined automatically by + -- SqlTypeExp. However, there's one corner case: if there's + -- a list of entity IDs, the datatype for the ID has not + -- yet been created, so the compiler will fail. This extra + -- clause works around this limitation. + FTList _ -> + SqlType' SqlString + _ -> + SqlTypeExp ftype + where + ftype = unboundFieldType field + +attrSqlType :: FieldAttr -> Maybe Text +attrSqlType = \case + FieldAttrSqltype x -> Just x + _ -> Nothing + +data SqlTypeExp + = SqlTypeExp FieldType + | SqlType' SqlType + | SqlTypeReference EntityNameHS + deriving (Show) + +liftSqlTypeExp :: SqlTypeExp -> Q Exp +liftSqlTypeExp ste = + case ste of + SqlType' t -> + lift t + SqlTypeExp ftype -> do + let + typ = ftToType ftype + mtyp = ConT ''Proxy `AppT` typ + typedNothing = SigE (ConE 'Proxy) mtyp + pure $ VarE 'sqlType `AppE` typedNothing + SqlTypeReference entNameHs -> do + let + entNameId :: Name + entNameId = + mkName $ T.unpack (unEntityNameHS entNameHs) <> "Id" + + [|sqlType (Proxy :: Proxy $(conT entNameId))|] + +type EmbedEntityMap = M.Map EntityNameHS () + +constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap +constructEmbedEntityMap = + M.fromList + . fmap + ( \ent -> + ( entityHaskell (unboundEntityDef ent) + , -- , toEmbedEntityDef (unboundEntityDef ent) + () + ) + ) + +lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS +lookupEmbedEntity allEntities field = do + let + mfieldTy = Just $ fieldType field + entName <- + EntityNameHS + <$> asum + [ do + FTTypeCon _ t <- mfieldTy + stripSuffix "Id" t + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy + pure entName + , do + FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- mfieldTy + stripSuffix "Id" t + ] + guard (M.member entName allEntities) -- check entity name exists in embed fmap + pure entName + +type EntityMap = M.Map EntityNameHS UnboundEntityDef + +constructEntityMap :: [UnboundEntityDef] -> EntityMap +constructEntityMap = + M.fromList . fmap (\ent -> (entityHaskell (unboundEntityDef ent), ent)) + +data FTTypeConDescr = FTKeyCon Text + deriving (Show) + +-- | Recurses through the 'FieldType'. Returns a 'Right' with the +-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of +-- a name and that name is present in the 'EmbedEntityMap' provided as +-- a first argument. +-- +-- If the 'FieldType' represents a @Key something@, this returns a @'Left +-- ('Just' 'FTKeyCon')@. +-- +-- If the 'FieldType' has a module qualified value, then it returns @'Left' +-- 'Nothing'@. +mEmbedded + :: M.Map EntityNameHS a + -> FieldType + -> Either (Maybe FTTypeConDescr) EntityNameHS +mEmbedded _ (FTTypeCon Just{} _) = + Left Nothing +mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = + maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents +mEmbedded _ (FTTypePromoted _) = + Left Nothing +mEmbedded ents (FTList x) = + mEmbedded ents x +mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) = + Left $ Just $ FTKeyCon $ a <> "Id" +mEmbedded _ (FTApp _ _) = + Left Nothing +mEmbedded _ (FTLit _) = + Left Nothing + +setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef +setEmbedField entName allEntities field = + case fieldReference field of + NoReference -> + setFieldReference ref field + _ -> + field + where + ref = + case mEmbedded allEntities (fieldType field) of + Left _ -> fromMaybe NoReference $ do + refEntName <- lookupEmbedEntity allEntities field + pure $ ForeignRef refEntName + Right em -> + if em /= entName + then EmbedRef em + else + if maybeNullable (unbindFieldDef field) + then SelfReference + else case fieldType field of + FTList _ -> SelfReference + _ -> + error $ + unpack $ + unEntityNameHS entName <> ": a self reference must be a Maybe or List" + +setFieldReference :: ReferenceDef -> FieldDef -> FieldDef +setFieldReference ref field = field{fieldReference = ref} + +-- | Create data types and appropriate 'PersistEntity' instances for the given +-- 'UnboundEntityDef's. +-- +-- This function should be used if you are only defining a single block of +-- Persistent models for the entire application. If you intend on defining +-- multiple blocks in different fiels, see 'mkPersistWith' which allows you +-- to provide existing entity definitions so foreign key references work. +-- +-- Example: +-- +-- @ +-- mkPersist 'sqlSettings' ['persistLowerCase'| +-- User +-- name Text +-- age Int +-- +-- Dog +-- name Text +-- owner UserId +-- +-- |] +-- @ +-- +-- Example from a file: +-- +-- @ +-- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels") +-- @ +-- +-- For full information on the 'QuasiQuoter' syntax, see +-- "Database.Persist.Quasi" documentation. +mkPersist + :: MkPersistSettings + -> [UnboundEntityDef] + -> Q [Dec] +mkPersist mps = mkPersistWith mps [] + +-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@ +-- representing the predefined entities. This function will include those +-- 'EntityDef' when looking for foreign key references. +-- +-- You should use this if you intend on defining Persistent models in +-- multiple files. +-- +-- Suppose we define a table @Foo@ which has no dependencies. +-- +-- @ +-- module DB.Foo where +-- +-- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'| +-- Foo +-- name Text +-- |] +-- @ +-- +-- Then, we define a table @Bar@ which depends on @Foo@: +-- +-- @ +-- module DB.Bar where +-- +-- import DB.Foo +-- +-- 'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'| +-- Bar +-- fooId FooId +-- |] +-- @ +-- +-- Writing out the list of 'EntityDef' can be annoying. The +-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate. +-- +-- @ +-- module DB.Quux where +-- +-- import DB.Foo +-- import DB.Bar +-- +-- 'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'| +-- Quux +-- name Text +-- fooId FooId +-- barId BarId +-- |] +-- @ +-- +-- @since 2.13.0.0 +mkPersistWith + :: MkPersistSettings + -> [EntityDef] + -> [UnboundEntityDef] + -> Q [Dec] +mkPersistWith mps preexistingEntities ents' = do + let + (embedEntityMap, predefs) = + preprocessUnboundDefs preexistingEntities ents' + allEnts = + embedEntityDefs preexistingEntities $ + fmap (setDefaultIdFields mps) $ + predefs + entityMap = + constructEntityMap allEnts + preexistingSet = + Set.fromList $ map getEntityHaskellName preexistingEntities + newEnts = + filter + (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet) + allEnts + ents <- filterM shouldGenerateCode newEnts + requireExtensions + [ [TypeFamilies] + , [GADTs, ExistentialQuantification] + , [DerivingStrategies] + , [GeneralizedNewtypeDeriving] + , [StandaloneDeriving] + , [UndecidableInstances] + , [DataKinds] + , [FlexibleInstances] + ] + persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents + entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents + jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents + uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents + safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents + symbolToFieldInstances <- + fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents + return $ + mconcat + [ persistFieldDecs + , entityDecs + , jsonDecs + , uniqueKeyInstances + , symbolToFieldInstances + , safeToInsertInstances + ] + +mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkSafeToInsertInstance mps ued = + case unboundPrimarySpec ued of + NaturalKey _ -> + instanceOkay + SurrogateKey uidDef -> do + let + attrs = + unboundIdAttrs uidDef + isDefaultFieldAttr = \case + FieldAttrDefault _ -> + True + _ -> + False + case unboundIdType uidDef of + Nothing -> + instanceOkay + Just _ -> + case List.find isDefaultFieldAttr attrs of + Nothing -> + badInstance + Just _ -> do + instanceOkay + DefaultKey _ -> + instanceOkay + where + typ :: Type + typ = genericDataType mps (getUnboundEntityNameHS ued) backendT + + mkInstance merr = + InstanceD + Nothing + (maybe id (:) merr withPersistStoreWriteCxt) + (ConT ''SafeToInsert `AppT` typ) + [] + instanceOkay = + pure + [ mkInstance Nothing + ] + badInstance = do + err <- [t|TypeError (SafeToInsertErrorMessage $(pure typ))|] + pure + [ mkInstance (Just err) + ] + + withPersistStoreWriteCxt = + if mpsGeneric mps + then + [ConT ''PersistStoreWrite `AppT` backendT] + else + [] + +-- we can't just use 'isInstance' because TH throws an error +shouldGenerateCode :: UnboundEntityDef -> Q Bool +shouldGenerateCode ed = do + mtyp <- lookupTypeName entityName + case mtyp of + Nothing -> do + pure True + Just typeName -> do + instanceExists <- isInstance ''PersistEntity [ConT typeName] + pure (not instanceExists) + where + entityName = + T.unpack . unEntityNameHS . getEntityHaskellName . unboundEntityDef $ ed + +overEntityDef + :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef +overEntityDef f ued = ued{unboundEntityDef = f (unboundEntityDef ued)} + +setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef +setDefaultIdFields mps ued + | defaultIdType ued = + overEntityDef + (setEntityIdDef (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed))) + ued + | otherwise = + ued + where + ed = + unboundEntityDef ued + setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef + setToMpsDefault iid (EntityIdField fd) = + EntityIdField + fd + { fieldType = + iidFieldType iid (getEntityHaskellName ed) + , fieldSqlType = + iidFieldSqlType iid + , fieldAttrs = + let + def = + toList (FieldAttrDefault <$> iidDefault iid) + maxlen = + toList (FieldAttrMaxlen <$> iidMaxLen iid) + in + def <> maxlen <> fieldAttrs fd + , fieldIsImplicitIdColumn = + True + } + setToMpsDefault _ x = + x + +-- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. +-- For example, strip out any fields marked as MigrationOnly. +-- +-- This should be called when performing Haskell codegen, but the 'EntityDef' +-- *should* keep all of the fields present when defining 'entityDef'. This is +-- necessary so that migrations know to keep these columns around, or to delete +-- them, as appropriate. +fixEntityDef :: UnboundEntityDef -> UnboundEntityDef +fixEntityDef ued = + ued + { unboundEntityFields = + filter isHaskellUnboundField (unboundEntityFields ued) + } + +-- | Settings that can be passed to the 'mkPersist' (mps) function to control what code is generated. +-- This is (just) the data type definition, so you will most likely want to use and adapt concrete values +-- like 'sqlSettings'. +data MkPersistSettings = MkPersistSettings + { mpsBackend :: Type + -- ^ Which database backend we\'re using. This type is used for the + -- 'PersistEntityBackend' associated type in the entities that are + -- generated. + -- + -- If the 'mpsGeneric' value is set to 'True', then this type is used for + -- the non-Generic type alias. The data and type will be named: + -- + -- @ + -- data ModelGeneric backend = Model { ... } + -- @ + -- + -- And, for convenience's sake, we provide a type alias: + -- + -- @ + -- type Model = ModelGeneric $(the type you give here) + -- @ + , mpsGeneric :: Bool + -- ^ Create generic types that can be used with multiple backends. Good for + -- reusable code, but makes error messages harder to understand. Default: + -- False. + , mpsPrefixFields :: Bool + -- ^ Prefix field names with the model name. Default: True. + -- + -- Note: this field is deprecated. Use the 'mpsFieldLabelModifier' and + -- 'mpsConstraintLabelModifier' instead. + , mpsFieldLabelModifier :: Text -> Text -> Text + -- ^ Customise the field names (and lens names) for generated entity data types. + -- + -- Default: appends entity name and field name, equivalent to + -- + -- @ + -- mpsFieldLabelModifier = \\entityName fieldName -> entityName <> fieldName + -- @ + -- + -- to avoid duplicate record field collisions. + -- + -- For example, with default 'sqlSettings' and + -- + -- @ + -- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'| + -- Person + -- name Text + -- age Int + -- |] + -- @ + -- + -- it will generate the entity data type + -- + -- @ + -- Person { + -- personName :: Text, -- generated field name + -- personAge :: Int -- generated field name + -- } + -- @ + -- + -- Note: this setting is ignored if the deprecated 'mpsPrefixFields' is set to False. + -- + -- === __Example without entity name__ + -- + -- You may not want the entity name prefix for all fields, so use + -- + -- @ + -- 'mkPersistWith' ('sqlSettings' { mpsFieldLabelModifier = \\\_entityName fieldName -> fieldName }) [] ['persistLowerCase'| + -- Person + -- name Text + -- age Int + -- |] + -- @ + -- + -- instead. This will generate the entity data type + -- + -- @ + -- Person { + -- name :: Text, + -- age :: Int + -- } + -- @ + -- + -- When you have multiple entites with the same field name, you might need to + -- add @{-# LANGUAGE DuplicateRecordFields #-}@ for your code to compile. + -- + -- @since 2.11.0.0 + , mpsAvoidHsKeyword :: Text -> Text + -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords. + -- + -- Default: suffix "_". + -- + -- @since 2.14.6.0 + , mpsConstraintLabelModifier :: Text -> Text -> Text + -- ^ Customise the Constraint names using the entity and field name. The + -- result should be a valid haskell type (start with an upper cased letter). + -- + -- Default: appends entity and field + -- + -- Note: this setting is ignored if the deprecated 'mpsPrefixFields' is set to False. + -- + -- @since 2.11.0.0 + , mpsEntityHaddocks :: Bool + -- ^ Generate Haddocks from entity documentation comments. Default: False. + -- + -- @since 2.14.6.0 + , mpsEntityJSON :: Maybe EntityJSON + -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's + -- @Nothing@, no instances will be generated. Default: + -- + -- @ + -- Just 'EntityJSON' + -- { 'entityToJSON' = 'entityIdToJSON + -- , 'entityFromJSON' = 'entityIdFromJSON + -- } + -- @ + , mpsGenerateLenses :: Bool + -- ^ Instead of generating normal field accessors, generator lens-style + -- accessors. + -- + -- Default: False + -- + -- @since 1.3.1 + , mpsDeriveInstances :: [Name] + -- ^ Automatically derive these typeclass instances for all record and key + -- types. + -- + -- Default: [] + -- + -- @since 2.8.1 + , mpsImplicitIdDef :: ImplicitIdDef + -- ^ TODO: document + -- + -- @since 2.13.0.0 + , mpsCamelCaseCompositeKeySelector :: Bool + -- ^ Should we generate composite key accessors in the correct CamelCase style. + -- + -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'False', + -- then the field part of the accessor starts with the lowercase. + -- This is a legacy style. + -- + -- @ + -- data Key CompanyUser = CompanyUserKey + -- { companyUserKeycompanyId :: CompanyId + -- , companyUserKeyuserId :: UserId + -- } + -- @ + -- + -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'True', + -- then field accessors are generated in CamelCase style. + -- + -- @ + -- data Key CompanyUser = CompanyUserKey + -- { companyUserKeyCompanyId :: CompanyId + -- , companyUserKeyUserId :: UserId + -- } + -- @ + -- Default: False + -- + -- @since 2.14.2.0 + } + +{-# DEPRECATED + mpsGeneric + "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" + #-} + +-- | Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default +-- value is 'autoIncrementingInteger'. +-- +-- @since 2.13.0.0 +setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings +setImplicitIdDef iid mps = + mps{mpsImplicitIdDef = iid} + +getImplicitIdType :: MkPersistSettings -> Type +getImplicitIdType = do + idDef <- mpsImplicitIdDef + isGeneric <- mpsGeneric + backendTy <- mpsBackend + pure $ iidType idDef isGeneric backendTy + +data EntityJSON = EntityJSON + { entityToJSON :: Name + -- ^ Name of the @toJSON@ implementation for @Entity a@. + , entityFromJSON :: Name + -- ^ Name of the @fromJSON@ implementation for @Entity a@. + } + +-- | Create an @MkPersistSettings@ with default values. +mkPersistSettings + :: Type + -- ^ Value for 'mpsBackend' + -> MkPersistSettings +mkPersistSettings backend = + MkPersistSettings + { mpsBackend = backend + , mpsGeneric = False + , mpsPrefixFields = True + , mpsFieldLabelModifier = (++) + , mpsAvoidHsKeyword = (++ "_") + , mpsConstraintLabelModifier = (++) + , mpsEntityHaddocks = False + , mpsEntityJSON = + Just + EntityJSON + { entityToJSON = 'entityIdToJSON + , entityFromJSON = 'entityIdFromJSON + } + , mpsGenerateLenses = False + , mpsDeriveInstances = [] + , mpsImplicitIdDef = + autoIncrementingInteger + , mpsCamelCaseCompositeKeySelector = False + } + +-- | Use the 'SqlPersist' backend. +sqlSettings :: MkPersistSettings +sqlSettings = mkPersistSettings $ ConT ''SqlBackend + +lowerFirst :: Text -> Text +lowerFirst t = + case uncons t of + Just (a, b) -> cons (toLower a) b + Nothing -> t + +upperFirst :: Text -> Text +upperFirst t = + case uncons t of + Just (a, b) -> cons (toUpper a) b + Nothing -> t + +dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec +dataTypeDec mps entityMap entDef = do + let + names = + mkEntityDefDeriveNames mps entDef + + let + (stocks, anyclasses) = partitionEithers (fmap stratFor names) + let + stockDerives = do + guard (not (null stocks)) + pure (DerivClause (Just StockStrategy) (fmap ConT stocks)) + anyclassDerives = do + guard (not (null anyclasses)) + pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses)) + unless (null anyclassDerives) $ do + requireExtensions [[DeriveAnyClass]] + let + dec = + DataD + [] + nameFinal + paramsFinal + Nothing + constrs + (stockDerives <> anyclassDerives) + conditionallyAddEntityHaddocks mps cols nameFinal entDef + pure dec + where + stratFor n = + if n `elem` stockClasses + then + Left n + else + Right n + + stockClasses = + Set.fromList + ( fmap + mkName + [ "Eq" + , "Ord" + , "Show" + , "Read" + , "Bounded" + , "Enum" + , "Ix" + , "Generic" + , "Data" + , "Typeable" + ] + <> [ ''Eq + , ''Ord + , ''Show + , ''Read + , ''Bounded + , ''Enum + , ''Ix + , ''Generic + , ''Data + , ''Typeable + ] + ) + + (nameFinal, paramsFinal) + | mpsGeneric mps = + ( mkEntityDefGenericName entDef + , + [ mkPlainTV backendName + ] + ) + | otherwise = + (mkEntityDefName entDef, []) + + cols :: [(VarBangType, Maybe Text)] + cols = do + fieldDef <- getUnboundFieldDefs entDef + let + recordNameE = + fieldDefToRecordName mps entDef fieldDef + strictness = + if unboundFieldStrict fieldDef + then isStrict + else notStrict + fieldIdType = + maybeIdType mps entityMap fieldDef Nothing Nothing + fieldComments = + unboundFieldComments fieldDef + pure ((recordNameE, strictness, fieldIdType), fieldComments) + + constrs + | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef + | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)] + + sumCon fieldDef = + NormalC + (sumConstrName mps entDef fieldDef) + [(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)] + +#if MIN_VERSION_template_haskell(2,18,0) +conditionallyAddEntityHaddocks + :: Foldable t + => MkPersistSettings + -> t ((Name, b, c), Maybe Text) + -> Name -> UnboundEntityDef -> Q () +conditionallyAddEntityHaddocks mps cols nameFinal entDef = + when (mpsEntityHaddocks mps) $ do + forM_ cols $ \((name, _, _), maybeComments) -> do + case maybeComments of + Just comment -> addModFinalizer $ + putDoc (DeclDoc name) (unpack comment) + Nothing -> pure () + case entityComments (unboundEntityDef entDef) of + Just doc -> do + addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc) + _ -> pure () +#else +conditionallyAddEntityHaddocks + :: Foldable t + => MkPersistSettings + -> t ((Name, b, c), Maybe Text) + -> Name -> UnboundEntityDef -> Q () +conditionallyAddEntityHaddocks _ _ _ _ = + pure () +#endif + +#if MIN_VERSION_template_haskell(2,15,0) +uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec +uniqueTypeDec mps entityMap entDef = + DataInstD + [] + Nothing + (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT)) + Nothing + (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef)) + [] +#else +uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec +uniqueTypeDec mps entityMap entDef = + DataInstD + [] + ''Unique + [genericDataType mps (getUnboundEntityNameHS entDef) backendT] + Nothing + (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef)) + [] +#endif + +mkUnique + :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con +mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = + NormalC (mkConstraintName constr) $ toList types + where + types = + fmap + (go . flip lookup3 (getUnboundFieldDefs entDef) . unFieldNameHS . fst) + fields + + force = "!force" `elem` attrs + + go :: (UnboundFieldDef, IsNullable) -> (Strict, Type) + go (_, Nullable _) | not force = error nullErrMsg + go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y)) + + lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable) + lookup3 s [] = + error $ + unpack $ + "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr + lookup3 x (fd : rest) + | x == unFieldNameHS (unboundFieldNameHS fd) = + (fd, isUnboundFieldNullable fd) + | otherwise = + lookup3 x rest + + nullErrMsg = + mconcat + [ "Error: By default Persistent disallows NULLables in an uniqueness " + , "constraint. The semantics of how NULL interacts with those constraints " + , "is non-trivial: most SQL implementations will not consider two NULL " + , "values to be equal for the purposes of an uniqueness constraint, " + , "allowing insertion of more than one row with a NULL value for the " + , "column in question. If you understand this feature of SQL and still " + , "intend to add a uniqueness constraint here, *** Use a \"!force\" " + , "attribute on the end of the line that defines your uniqueness " + , "constraint in order to disable this check. ***\n" + , "By default, this means using `getBy`, `insertBy`, or anything that fetches by unique key will NOT match if any of the fields are NULL." + ] + +-- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'. +-- It takes care to respect the 'mpsGeneric' setting to render an Id faithfully, +-- and it also ensures that the generated Haskell type is 'Maybe' if the +-- database column has that attribute. +-- +-- For a database schema with @'mpsGeneric' = False@, this is simple - it uses +-- the @ModelNameId@ type directly. This resolves just fine. +-- +-- If 'mpsGeneric' is @True@, then we have to do something a bit more +-- complicated. We can't refer to a @ModelNameId@ directly, because that @Id@ +-- alias hides the backend type variable. Instead, we need to refer to: +-- +-- > Key (ModelNameGeneric backend) +-- +-- This means that the client code will need both the term @ModelNameId@ in +-- scope, as well as the @ModelNameGeneric@ constructor, despite the fact that +-- the @ModelNameId@ is the only term explicitly used (and imported). +-- +-- However, we're not guaranteed to have @ModelName@ in scope - we've only +-- referenced @ModelNameId@ in code, and so code generation *should* work even +-- without this. Consider an explicit-style import: +-- +-- @ +-- import Model.Foo (FooId) +-- +-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| +-- Bar +-- foo FooId +-- |] +-- @ +-- +-- This looks like it ought to work, but it would fail with @mpsGeneric@ being +-- enabled. One hacky work-around is to perform a @'lookupTypeName' :: String -> +-- Q (Maybe Name)@ on the @"ModelNameId"@ type string. If the @Id@ is +-- a reference in the 'EntityMap' and @lookupTypeName@ returns @'Just' name@, +-- then that 'Name' contains the fully qualified information needed to use the +-- 'Name' without importing it at the client-site. Then we can perform a bit of +-- surgery on the 'Name' to strip the @Id@ suffix, turn it into a 'Type', and +-- apply the 'Key' constructor. +maybeIdType + :: MkPersistSettings + -> EntityMap + -> UnboundFieldDef + -> Maybe Name + -- ^ backend + -> Maybe IsNullable + -> Type +maybeIdType mps entityMap fieldDef mbackend mnull = + maybeTyp mayNullable idType + where + mayNullable = + case mnull of + Just (Nullable ByMaybeAttr) -> + True + _ -> + maybeNullable fieldDef + idType = + fromMaybe (ftToType $ unboundFieldType fieldDef) $ do + typ <- extractForeignRef entityMap fieldDef + guard ((mpsGeneric mps)) + pure $ + ConT ''Key + `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) + + -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then + -- append Generic to the model name, probably + _removeIdFromTypeSuffix :: Name -> Type + _removeIdFromTypeSuffix oldName@(Name (OccName nm) nameFlavor) = + case stripSuffix "Id" (T.pack nm) of + Nothing -> + ConT oldName + Just name -> + ConT ''Key + `AppT` do + ConT $ Name (OccName (T.unpack name)) nameFlavor + + -- \| TODO: if we keep mpsGeneric, let's incorporate this behavior here, so + -- end users don't need to import the constructor type as well as the id type + -- + -- Returns 'Nothing' if the given text does not appear to be a table reference. + -- In that case, do the usual thing for generating a type name. + -- + -- Returns a @Just typ@ if the text appears to be a model name, and if the + -- @ModelId@ type is in scope. The 'Type' is a fully qualified reference to + -- @'Key' ModelName@ such that end users won't have to import it directly. + _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type) + _lookupReferencedTable em fieldTypeText = do + let + mmodelIdString = do + fieldTypeNoId <- stripSuffix "Id" fieldTypeText + _ <- M.lookup (EntityNameHS fieldTypeNoId) em + pure (T.unpack fieldTypeText) + case mmodelIdString of + Nothing -> + pure Nothing + Just modelIdString -> do + mIdName <- lookupTypeName modelIdString + pure $ fmap _removeIdFromTypeSuffix mIdName + + _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String + _fieldNameEndsWithId ufd = go (unboundFieldType ufd) + where + go = \case + FTTypeCon mmodule name -> do + a <- stripSuffix "Id" name + pure $ + T.unpack $ + mconcat + [ case mmodule of + Nothing -> + "" + Just m -> + mconcat [m, "."] + , a + , "Id" + ] + _ -> + Nothing + +backendDataType :: MkPersistSettings -> Type +backendDataType mps + | mpsGeneric mps = backendT + | otherwise = mpsBackend mps + +-- | TODO: +-- +-- if we keep mpsGeneric +-- then +-- let's make this fully qualify the generic name +-- else +-- let's delete it +genericDataType + :: MkPersistSettings + -> EntityNameHS + -> Type + -- ^ backend + -> Type +genericDataType mps name backend + | mpsGeneric mps = + ConT (mkEntityNameHSGenericName name) `AppT` backend + | otherwise = + ConT $ mkEntityNameHSName name + +degen :: [Clause] -> [Clause] +degen [] = + let + err = + VarE 'error + `AppE` LitE + ( StringL + "Degenerate case, should never happen" + ) + in + [normalClause [WildP] err] +degen x = x + +-- needs: +-- + +-- * isEntitySum ed + +-- * field accesor + +-- * getEntityFields ed + +-- * used in goSum, or sumConstrName + +-- * mkEntityDefName ed + +-- * uses entityHaskell + +-- * sumConstrName ed fieldDef + +-- * only needs entity name and field name +-- +-- data MkToPersistFields = MkToPersistFields +-- { isEntitySum :: Bool +-- , entityHaskell :: HaskellNameHS +-- , entityFieldNames :: [FieldNameHS] +-- } +mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec +mkToPersistFields mps ed = do + let + isSum = unboundEntitySum ed + fields = getUnboundFieldDefs ed + clauses <- + if isSum + then sequence $ zipWith goSum fields [1 ..] + else fmap return go + return $ FunD 'toPersistFields clauses + where + go :: Q Clause + go = do + xs <- sequence $ replicate fieldCount $ newName "x" + let + name = mkEntityDefName ed + pat = conp name $ fmap VarP xs + sp <- [|toPersistValue|] + let + bod = ListE $ fmap (AppE sp . VarE) xs + return $ normalClause [pat] bod + + fieldCount = length (getUnboundFieldDefs ed) + + goSum :: UnboundFieldDef -> Int -> Q Clause + goSum fieldDef idx = do + let + name = sumConstrName mps ed fieldDef + enull <- [|PersistNull|] + let + beforeCount = idx - 1 + afterCount = fieldCount - idx + before = replicate beforeCount enull + after = replicate afterCount enull + x <- newName "x" + sp <- [|toPersistValue|] + let + body = + ListE $ + mconcat + [ before + , [sp `AppE` VarE x] + , after + ] + return $ normalClause [conp name [VarP x]] body + +mkToFieldNames :: [UniqueDef] -> Q Dec +mkToFieldNames pairs = do + pairs' <- mapM go pairs + return $ FunD 'persistUniqueToFieldNames $ degen pairs' + where + go (UniqueDef constr _ names _) = do + names' <- lift names + return $ + normalClause + [RecP (mkConstraintName constr) []] + names' + +mkUniqueToValues :: [UniqueDef] -> Q Dec +mkUniqueToValues pairs = do + pairs' <- mapM go pairs + return $ FunD 'persistUniqueToValues $ degen pairs' + where + go :: UniqueDef -> Q Clause + go (UniqueDef constr _ names _) = do + xs <- mapM (const $ newName "x") names + let + pat = conp (mkConstraintName constr) $ fmap VarP $ toList xs + tpv <- [|toPersistValue|] + let + bod = ListE $ fmap (AppE tpv . VarE) $ toList xs + return $ normalClause [pat] bod + +isNotNull :: PersistValue -> Bool +isNotNull PersistNull = False +isNotNull _ = True + +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft _ (Right r) = Right r +mapLeft f (Left l) = Left (f l) + +-- needs: +-- + +-- * getEntityFields + +-- * sumConstrName on field + +-- * fromValues + +-- * entityHaskell + +-- * sumConstrName + +-- * entityDefConE + +-- +-- +mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause] +mkFromPersistValues mps entDef + | unboundEntitySum entDef = do + nothing <- + [| + Left + ( "Invalid fromPersistValues input: sum type with all nulls. Entity: " + `mappend` entName + ) + |] + clauses <- mkClauses [] $ getUnboundFieldDefs entDef + return $ clauses `mappend` [normalClause [WildP] nothing] + | otherwise = + fromValues entDef "fromPersistValues" entE $ + fmap unboundFieldNameHS $ + filter isHaskellUnboundField $ + getUnboundFieldDefs entDef + where + entName = unEntityNameHS $ getUnboundEntityNameHS entDef + mkClauses _ [] = return [] + mkClauses before (field : after) = do + x <- newName "x" + let + null' = conp 'PersistNull [] + pat = + ListP $ + mconcat + [ fmap (const null') before + , [VarP x] + , fmap (const null') after + ] + constr = ConE $ sumConstrName mps entDef field + fs <- [|fromPersistValue $(return $ VarE x)|] + let + guard' = NormalG $ VarE 'isNotNull `AppE` VarE x + let + clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] + clauses <- mkClauses (field : before) after + return $ clause : clauses + entE = entityDefConE entDef + +type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t + +lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) + +fmapE :: Exp +fmapE = VarE 'fmap + +unboundEntitySum :: UnboundEntityDef -> Bool +unboundEntitySum = entitySum . unboundEntityDef + +fieldSel :: Name -> Name -> Exp +fieldSel conName fieldName = + LamE [RecP conName [(fieldName, VarP xName)]] (VarE xName) + where + xName = mkName "x" + +fieldUpd + :: Name + -- ^ constructor name + -> [Name] + -- ^ list of field names + -> Exp + -- ^ record value + -> Name + -- ^ field name to update + -> Exp + -- ^ new value + -> Q Exp +fieldUpd con names record name new = do + pats <- + fmap mconcat $ forM names $ \k -> do + varName <- VarP <$> newName (nameBase k) + pure [(k, varName) | k /= name] + + pure $ + CaseE + record + [Match (RecP con pats) (NormalB body) []] + where + body = + RecConE + con + [ if k == name then (name, new) else (k, VarE k) + | k <- names + ] + +mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause] +mkLensClauses mps entDef _genDataType = do + lens' <- [|lensPTH|] + getId <- [|entityKey|] + setId <- [|\(Entity _ value) key -> Entity key value|] + getVal <- [|entityVal|] + dot <- [|(.)|] + keyVar <- newName "key" + valName <- newName "value" + xName <- newName "x" + let + idClause = + normalClause + [conp (keyIdName entDef) []] + (lens' `AppE` getId `AppE` setId) + (idClause :) + <$> if unboundEntitySum entDef + then + pure $ + fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef) + else + zipWithM + (toClause lens' getVal dot keyVar valName xName) + (getUnboundFieldDefs entDef) + fieldNames + where + fieldNames = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef + toClause lens' getVal dot keyVar valName xName fieldDef fieldName = do + setter <- mkSetter + pure $ + normalClause + [conp (filterConName mps entDef fieldDef) []] + (lens' `AppE` getter `AppE` setter) + where + defName = mkEntityDefName entDef + getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal) + mkSetter = do + updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName) + pure + $ LamE + [ conp 'Entity [VarP keyVar, VarP valName] + , VarP xName + ] + $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr + + toSumClause lens' keyVar valName xName fieldDef = + normalClause + [conp (filterConName mps entDef fieldDef) []] + (lens' `AppE` getter `AppE` setter) + where + emptyMatch = + Match + WildP + ( NormalB $ + VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type") + ) + [] + getter = + LamE + [ conp 'Entity [WildP, VarP valName] + ] + $ CaseE (VarE valName) + $ Match + (conp (sumConstrName mps entDef fieldDef) [VarP xName]) + (NormalB $ VarE xName) + [] + -- FIXME It would be nice if the types expressed that the Field is + -- a sum type and therefore could result in Maybe. + : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else [] + setter = + LamE + [ conp 'Entity [VarP keyVar, WildP] + , VarP xName + ] + $ ConE 'Entity + `AppE` VarE keyVar + `AppE` (ConE (sumConstrName mps entDef fieldDef) `AppE` VarE xName) + +-- | declare the key type and associated instances +-- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field +mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec]) +mkKeyTypeDec mps entDef = do + (instDecs, i) <- + if mpsGeneric mps + then + if not useNewtype + then do + pfDec <- pfInstD + return (pfDec, supplement [''Generic]) + else do + gi <- genericNewtypeInstances + return (gi, supplement []) + else + if not useNewtype + then do + pfDec <- pfInstD + return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic]) + else do + let + allInstances = + supplement + [ ''Show + , ''Read + , ''Eq + , ''Ord + , ''PathPiece + , ''ToHttpApiData + , ''FromHttpApiData + , ''PersistField + , ''PersistFieldSql + , ''ToJSON + , ''FromJSON + ] + if customKeyType + then return ([], allInstances) + else do + bi <- backendKeyI + return (bi, allInstances) + + requirePersistentExtensions + + -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1" + -- This is much better for debugging/logging purposes + -- cf. https://github.com/yesodweb/persistent/issues/1104 + let + alwaysStockStrategyTypeclasses = [''Show, ''Read] + deriveClauses = + fmap + ( \typeclass -> + if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses) + then DerivClause (Just StockStrategy) [(ConT typeclass)] + else DerivClause (Just NewtypeStrategy) [(ConT typeclass)] + ) + i + + let + kd = mkKeyDeclaration useNewtype k recordType dec deriveClauses + return (kd, instDecs) + where + keyConE = keyConExp entDef + unKeyE = unKeyExp entDef + dec = RecC (keyConName entDef) (toList $ keyFields mps entDef) + k = ''Key + recordType = + genericDataType mps (getUnboundEntityNameHS entDef) backendT + pfInstD = + -- FIXME: generate a PersistMap instead of PersistList + [d| + instance PersistField (Key $(pure recordType)) where + toPersistValue = PersistList . keyToValues + fromPersistValue (PersistList l) = keyFromValues l + fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got + + instance PersistFieldSql (Key $(pure recordType)) where + sqlType _ = SqlString + + instance ToJSON (Key $(pure recordType)) + + instance FromJSON (Key $(pure recordType)) + |] + + backendKeyGenericI = + [d| + instance + (PersistStore $(pure backendT)) + => ToBackendKey $(pure backendT) $(pure recordType) + where + toBackendKey = $(return unKeyE) + fromBackendKey = $(return keyConE) + |] + backendKeyI = + let + bdt = backendDataType mps + in + [d| + instance ToBackendKey $(pure bdt) $(pure recordType) where + toBackendKey = $(return unKeyE) + fromBackendKey = $(return keyConE) + |] + + genericNewtypeInstances = do + requirePersistentExtensions + + alwaysInstances <- + -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here + [d| + deriving stock instance + (Show (BackendKey $(pure backendT))) => Show (Key $(pure recordType)) + + deriving stock instance + (Read (BackendKey $(pure backendT))) => Read (Key $(pure recordType)) + + deriving newtype instance + (Eq (BackendKey $(pure backendT))) => Eq (Key $(pure recordType)) + + deriving newtype instance + (Ord (BackendKey $(pure backendT))) => Ord (Key $(pure recordType)) + + deriving newtype instance + (ToHttpApiData (BackendKey $(pure backendT))) + => ToHttpApiData (Key $(pure recordType)) + + deriving newtype instance + (FromHttpApiData (BackendKey $(pure backendT))) + => FromHttpApiData (Key $(pure recordType)) + + deriving newtype instance + (PathPiece (BackendKey $(pure backendT))) => PathPiece (Key $(pure recordType)) + + deriving newtype instance + (PersistField (BackendKey $(pure backendT))) + => PersistField (Key $(pure recordType)) + + deriving newtype instance + (PersistFieldSql (BackendKey $(pure backendT))) + => PersistFieldSql (Key $(pure recordType)) + + deriving newtype instance + (ToJSON (BackendKey $(pure backendT))) => ToJSON (Key $(pure recordType)) + + deriving newtype instance + (FromJSON (BackendKey $(pure backendT))) => FromJSON (Key $(pure recordType)) + |] + + mappend alwaysInstances + <$> if customKeyType + then pure [] + else backendKeyGenericI + + useNewtype = pkNewtype mps entDef + customKeyType = + or + [ not (defaultIdType entDef) + , not useNewtype + , isJust (entityPrimary (unboundEntityDef entDef)) + , not isBackendKey + ] + + isBackendKey = + case getImplicitIdType mps of + ConT bk `AppT` _ + | bk == ''BackendKey -> + True + _ -> + False + + supplement :: [Name] -> [Name] + supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) + +#if MIN_VERSION_template_haskell(2,15,0) +mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec +mkKeyDeclaration useNewtype k recordType dec deriveClauses = + if useNewtype + then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses + else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses +#else +mkKeyDeclaration :: Bool -> Name -> Type -> Con -> [DerivClause] -> Dec +mkKeyDeclaration useNewtype k recordType dec deriveClauses = + if useNewtype + then NewtypeInstD [] k [recordType] Nothing dec deriveClauses + else DataInstD [] k [recordType] Nothing [dec] deriveClauses +#endif + +-- | Returns 'True' if the key definition has less than 2 fields. +-- +-- @since 2.11.0.0 +pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool +pkNewtype mps entDef = length (keyFields mps entDef) < 2 + +-- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the +-- QuasiQuoter produces for an implicit ID and +defaultIdType :: UnboundEntityDef -> Bool +defaultIdType entDef = + case unboundPrimarySpec entDef of + DefaultKey _ -> + True + _ -> + False + +keyFields + :: MkPersistSettings -> UnboundEntityDef -> NonEmpty (Name, Strict, Type) +keyFields mps entDef = + case unboundPrimarySpec entDef of + NaturalKey ucd -> + fmap naturalKeyVar (unboundCompositeCols ucd) + DefaultKey _ -> + pure . idKeyVar $ getImplicitIdType mps + SurrogateKey k -> + pure . idKeyVar $ case unboundIdType k of + Nothing -> + getImplicitIdType mps + Just ty -> + ftToType ty + where + unboundFieldDefs = + getUnboundFieldDefs entDef + naturalKeyVar fieldName = + case findField fieldName unboundFieldDefs of + Nothing -> + error "column not defined on entity" + Just unboundFieldDef -> + ( keyFieldName mps entDef (unboundFieldNameHS unboundFieldDef) + , notStrict + , ftToType $ unboundFieldType unboundFieldDef + ) + + idKeyVar ft = + ( unKeyName entDef + , notStrict + , ft + ) + +findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef +findField fieldName = + List.find ((fieldName ==) . unboundFieldNameHS) + +mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec +mkKeyToValues mps entDef = do + recordN <- newName "record" + FunD 'keyToValues . pure + <$> case unboundPrimarySpec entDef of + NaturalKey ucd -> do + normalClause [VarP recordN] + <$> toValuesPrimary recordN ucd + _ -> do + normalClause [] + <$> [|(: []) . toPersistValue . $(pure $ unKeyExp entDef)|] + where + toValuesPrimary recName ucd = + ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd) + f recName fieldNameHS = + [| + toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName)) + |] + keyFieldSel name = + fieldSel (keyConName entDef) (keyFieldName mps entDef name) + +normalClause :: [Pat] -> Exp -> Clause +normalClause p e = Clause p (NormalB e) [] + +-- needs: +-- + +-- * entityPrimary + +-- * keyConExp entDef +mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec +mkKeyFromValues _mps entDef = + FunD 'keyFromValues + <$> case unboundPrimarySpec entDef of + NaturalKey ucd -> + fromValues entDef "keyFromValues" keyConE (toList $ unboundCompositeCols ucd) + _ -> do + e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] + return [normalClause [] e] + where + keyConE = keyConExp entDef + +headNote :: [PersistValue] -> PersistValue +headNote = \case + [x] -> x + xs -> + error $ + "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs + +-- needs from entity: +-- + +-- * entityText entDef + +-- * entityHaskell + +-- * entityDB entDef + +-- +-- needs from fields: +-- + +-- * mkPersistValue + +-- * fieldHaskell +-- +-- data MkFromValues = MkFromValues +-- { entityHaskell :: EntityNameHS +-- , entityDB :: EntitynameDB +-- , entityFieldNames :: [FieldNameHS] +-- } +fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause] +fromValues entDef funName constructExpr fields = do + x <- newName "x" + let + funMsg = + mconcat + [ entityText entDef + , ": " + , funName + , " failed on: " + ] + patternMatchFailure <- + [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] + suc <- patternSuccess + return [suc, normalClause [VarP x] patternMatchFailure] + where + tableName = + unEntityNameDB (entityDB (unboundEntityDef entDef)) + patternSuccess = + case fields of + [] -> do + rightE <- [|Right|] + return $ normalClause [ListP []] (rightE `AppE` constructExpr) + _ -> do + x1 <- newName "x1" + restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2 .. length fields] + (fpv1 : mkPersistValues) <- mapM mkPersistValue fields + app1E <- [|(<$>)|] + let + conApp = infixFromPersistValue app1E fpv1 constructExpr x1 + applyE <- [|(<*>)|] + let + applyFromPersistValue = infixFromPersistValue applyE + + return $ + normalClause + [ListP $ fmap VarP (x1 : restNames)] + ( List.foldl' + (\exp (name, fpv) -> applyFromPersistValue fpv exp name) + conApp + (zip restNames mkPersistValues) + ) + + infixFromPersistValue applyE fpv exp name = + UInfixE exp applyE (fpv `AppE` VarE name) + + mkPersistValue field = + let + fieldName = unFieldNameHS field + in + [|mapLeft (fieldError tableName fieldName) . fromPersistValue|] + +-- | Render an error message based on the @tableName@ and @fieldName@ with +-- the provided message. +-- +-- @since 2.8.2 +fieldError :: Text -> Text -> Text -> Text +fieldError tableName fieldName err = + mconcat + [ "Couldn't parse field `" + , fieldName + , "` from table `" + , tableName + , "`. " + , err + ] + +mkEntity + :: M.Map EntityNameHS a + -> EntityMap + -> MkPersistSettings + -> UnboundEntityDef + -> Q [Dec] +mkEntity embedEntityMap entityMap mps preDef = do + when (isEntitySum (unboundEntityDef preDef)) $ do + reportWarning $ + unlines + [ "persistent has deprecated sum type entities as of 2.14.0.0." + , "We will delete support for these entities in 2.15.0.0." + , "If you need these, please add a comment on this GitHub issue:" + , "" + , " https://github.com/yesodweb/persistent/issues/987" + ] + + entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef + let + entDef = + fixEntityDef preDef + fields <- mkFields mps entityMap entDef + let + name = mkEntityDefName entDef + let + clazz = ConT ''PersistEntity `AppT` genDataType + tpf <- mkToPersistFields mps entDef + fpv <- mkFromPersistValues mps entDef + utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef + puk <- mkUniqueKeys entDef + fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef + + toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef + + (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef + keyToValues' <- mkKeyToValues mps entDef + keyFromValues' <- mkKeyFromValues mps entDef + + let + addSyn -- FIXME maybe remove this + | mpsGeneric mps = + (:) $ + TySynD name [] $ + genericDataType mps entName $ + mpsBackend mps + | otherwise = id + + lensClauses <- mkLensClauses mps entDef genDataType + + lenses <- mkLenses mps entityMap entDef + let + instanceConstraint = + if not (mpsGeneric mps) + then [] + else + [mkClassP ''PersistStore [backendT]] + + [keyFromRecordM'] <- + case unboundPrimarySpec entDef of + NaturalKey ucd -> do + let + keyFields' = fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd + keyFieldNames' <- forM keyFields' $ \fieldName -> do + fieldVarName <- newName (nameBase fieldName) + return (fieldName, fieldVarName) + + let + keyCon = keyConName entDef + constr = + List.foldl' + AppE + (ConE keyCon) + (VarE . snd <$> keyFieldNames') + keyFromRec = varP 'keyFromRecordM + fieldPat = + [ (fieldName, VarP fieldVarName) + | (fieldName, fieldVarName) <- toList keyFieldNames' + ] + lam = LamE [RecP name fieldPat] constr + [d| + $(keyFromRec) = Just $(pure lam) + |] + _ -> + [d|$(varP 'keyFromRecordM) = Nothing|] + + dtd <- dataTypeDec mps entityMap entDef + let + allEntDefs = + entityFieldTHCon <$> efthAllFields fields + allEntDefClauses = + entityFieldTHClause <$> efthAllFields fields + + mkTabulateApply <- do + fromFieldName <- newName "fromField" + let + names'types = + filter (\(n, _) -> n /= mkName "Id") $ + map (getConNameAndType . entityFieldTHCon) $ + entityFieldsTHFields fields + getConNameAndType = \case + ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC conName []) -> + (conName, fieldTy) + other -> + error $ + mconcat + [ "persistent internal error: field constructor did not have xpected shape. \n" + , "Expected: \n" + , " ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n" + , "Got: \n" + , " " <> show other + ] + mkEntityVal = + fst $ + List.foldl' + ( \(acc, op) (n, _) -> + ( InfixE + (Just acc) + op + (Just (VarE fromFieldName `AppE` ConE n)) + , VarE '(<.>) + ) + ) + (ConE (mkEntityNameHSName entName), VarE '(<$>)) + names'types + primaryKeyField = + fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields + body <- + if isEntitySum $ unboundEntityDef entDef + then [|error "tabulateEntityApply does not make sense for sum type"|] + else + if null names'types + then + [| + (\k -> Entity k $(conE (mkEntityNameHSName entName))) + <$> $(varE fromFieldName) $(conE primaryKeyField) + |] + else + [| + Entity + <$> $(varE fromFieldName) $(conE primaryKeyField) + <.> $(pure mkEntityVal) + |] + + pure $ + FunD + 'tabulateEntityApply + [ Clause [VarP fromFieldName] (NormalB body) [] + ] + + mkTabulateA <- do + fromFieldName <- newName "fromField" + let + names'types = + filter (\(n, _) -> n /= mkName "Id") $ + map (getConNameAndType . entityFieldTHCon) $ + entityFieldsTHFields fields + getConNameAndType = \case + ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC conName []) -> + (conName, fieldTy) + other -> + error $ + mconcat + [ "persistent internal error: field constructor did not have xpected shape. \n" + , "Expected: \n" + , " ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n" + , "Got: \n" + , " " <> show other + ] + mkEntityVal = + List.foldl' + ( \acc (n, _) -> + InfixE + (Just acc) + (VarE '(<*>)) + (Just (VarE fromFieldName `AppE` ConE n)) + ) + (VarE 'pure `AppE` ConE (mkEntityNameHSName entName)) + names'types + primaryKeyField = + fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields + body <- + if isEntitySum $ unboundEntityDef entDef + then [|error "tabulateEntityA does not make sense for sum type"|] + else + [| + Entity + <$> $(varE fromFieldName) $(conE primaryKeyField) + <*> $(pure mkEntityVal) + |] + + pure $ + FunD + 'tabulateEntityA + [ Clause [VarP fromFieldName] (NormalB body) [] + ] + + return $ + addSyn $ + dtd + : mconcat fkc + `mappend` ( [ TySynD (keyIdName entDef) [] $ + ConT ''Key `AppT` ConT name + , instanceD + instanceConstraint + clazz + [ uniqueTypeDec mps entityMap entDef + , keyTypeDec + , keyToValues' + , keyFromValues' + , keyFromRecordM' + , mkTabulateA + , mkTabulateApply + , FunD 'entityDef [normalClause [WildP] entityDefExp] + , tpf + , FunD 'fromPersistValues fpv + , toFieldNames + , utv + , puk + , mkEntityFieldDataInstance genDataType allEntDefs + , FunD 'persistFieldDef allEntDefClauses + , mkTySynInstanceForBackend mps genDataType + , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)] + , FunD 'fieldLens lensClauses + ] + ] + `mappend` lenses + ) + `mappend` keyInstanceDecs + where + genDataType = + genericDataType mps entName backendT + entName = + getUnboundEntityNameHS preDef + +#if MIN_VERSION_template_haskell(2,15,0) +mkEntityFieldDataInstance :: Type -> [Con] -> Dec +mkEntityFieldDataInstance genDataType allEntDefs = + DataInstD + [] + Nothing + (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) + Nothing + allEntDefs + [] +#else +mkEntityFieldDataInstance :: Type -> [Con] -> Dec +mkEntityFieldDataInstance genDataType allEntDefs = + DataInstD + [] + ''EntityField + [ genDataType + , VarT $ mkName "typ" + ] + Nothing + allEntDefs + [] +#endif + +#if MIN_VERSION_template_haskell(2,15,0) +mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec +mkTySynInstanceForBackend mps genDataType = + TySynInstD + (TySynEqn + Nothing + (AppT (ConT ''PersistEntityBackend) genDataType) + (backendDataType mps)) +#else +mkTySynInstanceForBackend :: MkPersistSettings -> Type -> Dec +mkTySynInstanceForBackend mps genDataType = + TySynInstD + ''PersistEntityBackend + (TySynEqn + [genDataType] + (backendDataType mps)) +#endif + +data EntityFieldsTH = EntityFieldsTH + { entityFieldsTHPrimary :: EntityFieldTH + , entityFieldsTHFields :: [EntityFieldTH] + } + +efthAllFields :: EntityFieldsTH -> [EntityFieldTH] +efthAllFields EntityFieldsTH{..} = + stripIdFieldDef entityFieldsTHPrimary : entityFieldsTHFields + +stripIdFieldDef :: EntityFieldTH -> EntityFieldTH +stripIdFieldDef efth = + efth + { entityFieldTHClause = + go (entityFieldTHClause efth) + } + where + go (Clause ps bdy ds) = + Clause ps bdy' ds + where + bdy' = + case bdy of + NormalB e -> + NormalB $ AppE (VarE 'stripIdFieldImpl) e + _ -> + bdy + +-- | @persistent@ used to assume that an Id was always a single field. +-- +-- This method preserves as much backwards compatibility as possible. +stripIdFieldImpl :: (HasCallStack) => EntityIdDef -> FieldDef +stripIdFieldImpl eid = + case eid of + EntityIdField fd -> fd + EntityIdNaturalKey cd -> + case compositeFields cd of + (x :| xs) -> + case xs of + [] -> + x + _ -> + dummyFieldDef + where + dummyFieldDef = + FieldDef + { fieldHaskell = + FieldNameHS "Id" + , fieldDB = + FieldNameDB "__composite_key_no_id__" + , fieldType = + FTTypeCon Nothing "__Composite_Key__" + , fieldSqlType = + SqlOther "Composite Key" + , fieldAttrs = + [] + , fieldStrict = + False + , fieldReference = + NoReference + , fieldCascade = + noCascade + , fieldComments = + Nothing + , fieldGenerated = + Nothing + , fieldIsImplicitIdColumn = + False + } + +mkFields + :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH +mkFields mps entityMap entDef = + EntityFieldsTH + <$> mkIdField mps entDef + <*> mapM (mkField mps entityMap entDef) (getUnboundFieldDefs entDef) + +mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkUniqueKeyInstances mps entDef = do + requirePersistentExtensions + case entityUniques (unboundEntityDef entDef) of + [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne + [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey + (_ : _) -> mappend <$> typeErrorMultiple <*> atLeastOneKey + where + requireUniquesPName = 'requireUniquesP + onlyUniquePName = 'onlyUniqueP + typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx + typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx + + withPersistStoreWriteCxt = + if mpsGeneric mps + then do + write <- [t|PersistStoreWrite $(pure backendT)|] + pure [write] + else do + pure [] + + typeErrorNoneCtx = do + tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|] + (tyErr :) <$> withPersistStoreWriteCxt + + typeErrorMultipleCtx = do + tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|] + (tyErr :) <$> withPersistStoreWriteCxt + + mkOnlyUniqueError :: Q Cxt -> Q [Dec] + mkOnlyUniqueError mkCtx = do + ctx <- mkCtx + let + impl = mkImpossible onlyUniquePName + pure [instanceD ctx onlyOneUniqueKeyClass impl] + + mkImpossible name = + [ FunD + name + [ Clause + [WildP] + ( NormalB + (VarE 'error `AppE` LitE (StringL "impossible")) + ) + [] + ] + ] + + typeErrorAtLeastOne :: Q [Dec] + typeErrorAtLeastOne = do + let + impl = mkImpossible requireUniquesPName + cxt <- typeErrorNoneCtx + pure [instanceD cxt atLeastOneUniqueKeyClass impl] + + singleUniqueKey :: Q [Dec] + singleUniqueKey = do + expr <- [e|head . persistUniqueKeys|] + let + impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] + cxt <- withPersistStoreWriteCxt + pure [instanceD cxt onlyOneUniqueKeyClass impl] + + atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType + onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType + + atLeastOneKey :: Q [Dec] + atLeastOneKey = do + expr <- [e|NEL.fromList . persistUniqueKeys|] + let + impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] + cxt <- withPersistStoreWriteCxt + pure [instanceD cxt atLeastOneUniqueKeyClass impl] + + genDataType = + genericDataType mps (getUnboundEntityNameHS entDef) backendT + +entityText :: UnboundEntityDef -> Text +entityText = unEntityNameHS . getUnboundEntityNameHS + +mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] +mkLenses mps _ _ | not (mpsGenerateLenses mps) = return [] +mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return [] +mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` fieldNames) $ \(field, fieldName) -> do + let + lensName = mkEntityLensName mps ent field + needleN <- newName "needle" + setterN <- newName "setter" + fN <- newName "f" + aN <- newName "a" + yN <- newName "y" + let + needle = VarE needleN + setter = VarE setterN + f = VarE fN + a = VarE aN + y = VarE yN + fT = mkName "f" + -- FIXME if we want to get really fancy, then: if this field is the + -- \*only* Id field present, then set backend1 and backend2 to different + -- values + backend1 = backendName + backend2 = backendName + aT = + maybeIdType mps entityMap field (Just backend1) Nothing + bT = + maybeIdType mps entityMap field (Just backend2) Nothing + mkST backend = + genericDataType mps (getUnboundEntityNameHS ent) (VarT backend) + sT = mkST backend1 + tT = mkST backend2 + t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 + vars = + mkForallTV fT + : (if mpsGeneric mps then [mkForallTV backend1 {-, PlainTV backend2-}] else []) + fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y + return + [ SigD lensName $ + ForallT vars [mkClassP ''Functor [VarT fT]] $ + (aT `arrow` (VarT fT `AppT` bT)) + `arrow` (sT `arrow` (VarT fT `AppT` tT)) + , FunD lensName $ + return $ + Clause + [VarP fN, VarP aN] + ( NormalB $ + fmapE + `AppE` setter + `AppE` (f `AppE` needle) + ) + [ FunD + needleN + [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)] + , FunD setterN $ + return $ + normalClause + [VarP yN] + fieldUpdClause + ] + ] + where + fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent + +#if MIN_VERSION_template_haskell(2,21,0) +mkPlainTV + :: Name + -> TyVarBndr BndrVis +mkPlainTV n = PlainTV n defaultBndrFlag + +mkForallTV :: Name -> TyVarBndr Specificity +mkForallTV n = PlainTV n SpecifiedSpec +#elif MIN_VERSION_template_haskell(2,17,0) +mkPlainTV + :: Name + -> TyVarBndr () +mkPlainTV n = PlainTV n () + +mkForallTV :: Name -> TyVarBndr Specificity +mkForallTV n = PlainTV n SpecifiedSpec +#else + +mkPlainTV + :: Name + -> TyVarBndr +mkPlainTV = PlainTV + +mkForallTV + :: Name + -> TyVarBndr +mkForallTV = mkPlainTV +#endif + +mkForeignKeysComposite + :: MkPersistSettings + -> UnboundEntityDef + -> UnboundForeignDef + -> Q [Dec] +mkForeignKeysComposite mps entDef foreignDef + | foreignToPrimary (unboundForeignDef foreignDef) = do + let + fieldName = + fieldNameToRecordName mps entDef + fname = + fieldName $ + constraintToField $ + foreignConstraintNameHaskell $ + unboundForeignDef foreignDef + reftableString = + unpack $ unEntityNameHS $ foreignRefTableHaskell $ unboundForeignDef foreignDef + reftableKeyName = + mkName $ reftableString `mappend` "Key" + tablename = + mkEntityDefName entDef + fieldStore = + mkFieldStore entDef + + recordVarName <- newName "record_mkForeignKeysComposite" + + let + mkFldE foreignName = + -- using coerce here to convince SqlBackendKey to go away + VarE 'coerce + `AppE` (VarE (fieldName foreignName) `AppE` VarE recordVarName) + mkFldR ffr = + let + e = + mkFldE (ffrSourceField ffr) + in + case ffrTargetField ffr of + FieldNameHS "Id" -> + VarE 'toBackendKey + `AppE` e + _ -> + e + foreignFieldNames foreignFieldList = + case foreignFieldList of + FieldListImpliedId names -> + names + FieldListHasReferences refs -> + fmap ffrSourceField refs + + fldsE = + getForeignNames $ (unboundForeignFields foreignDef) + getForeignNames = \case + FieldListImpliedId xs -> + fmap mkFldE xs + FieldListHasReferences xs -> + fmap mkFldR xs + + nullErr n = + error $ "Could not find field definition for: " <> show n + fNullable = + setNull $ + fmap (\n -> fromMaybe (nullErr n) $ getFieldDef n fieldStore) $ + foreignFieldNames $ + unboundForeignFields foreignDef + mkKeyE = + List.foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE + fn = + FunD fname [normalClause [VarP recordVarName] mkKeyE] + + keyTargetTable = + maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString) + + sigTy <- [t|$(conT tablename) -> $(pure keyTargetTable)|] + pure + [ SigD fname sigTy + , fn + ] + | otherwise = + pure [] + where + constraintToField = FieldNameHS . unConstraintNameHS + +maybeExp :: Bool -> Exp -> Exp +maybeExp may exp + | may = fmapE `AppE` exp + | otherwise = exp + +maybeTyp :: Bool -> Type -> Type +maybeTyp may typ + | may = ConT ''Maybe `AppT` typ + | otherwise = typ + +entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue +entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues + where + columnNames = + fmap (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity))) + fieldsAsPersistValues = fmap toPersistValue $ toPersistFields entity + +entityFromPersistValueHelper + :: (PersistEntity record) + => [String] + -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code + -> PersistValue + -> Either Text record +entityFromPersistValueHelper columnNames pv = do + (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv + + let + columnMap = HM.fromList persistMap + lookupPersistValueByColumnName :: String -> PersistValue + lookupPersistValueByColumnName columnName = + fromMaybe PersistNull (HM.lookup (pack columnName) columnMap) + + fromPersistValues $ fmap lookupPersistValueByColumnName columnNames + +-- | Produce code similar to the following: +-- +-- @ +-- instance PersistEntity e => PersistField e where +-- toPersistValue = entityToPersistValueHelper +-- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] +-- sqlType _ = SqlString +-- @ +persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +persistFieldFromEntity mps entDef = do + sqlStringConstructor' <- [|SqlString|] + toPersistValueImplementation <- [|entityToPersistValueHelper|] + fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|] + + return + [ persistFieldInstanceD + (mpsGeneric mps) + typ + [ FunD 'toPersistValue [normalClause [] toPersistValueImplementation] + , FunD + 'fromPersistValue + [normalClause [] fromPersistValueImplementation] + ] + , persistFieldSqlInstanceD + (mpsGeneric mps) + typ + [ sqlTypeFunD sqlStringConstructor' + ] + ] + where + typ = + genericDataType mps (entityHaskell (unboundEntityDef entDef)) backendT + entFields = + filter isHaskellUnboundField $ getUnboundFieldDefs entDef + columnNames = + fmap (unpack . unFieldNameHS . unboundFieldNameHS) entFields + +-- | Apply the given list of functions to the same @EntityDef@s. +-- +-- This function is useful for cases such as: +-- +-- @ +-- share ['mkEntityDefList' "myDefs", 'mkPersist' sqlSettings] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- If you only have a single function, though, you don't need this. The +-- following is redundant: +-- +-- @ +-- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- Most functions require a full @['EntityDef']@, which can be provided +-- using @$('discoverEntities')@ for all entites in scope, or defining +-- 'mkEntityDefList' to define a list of entities from the given block. +share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] +share fs x = mconcat <$> mapM ($ x) fs + +-- | Creates a declaration for the @['EntityDef']@ from the @persistent@ +-- schema. This is necessary because the Persistent QuasiQuoter is unable +-- to know the correct type of ID fields, and assumes that they are all +-- Int64. +-- +-- Provide this in the list you give to 'share', much like @'mkMigrate'@. +-- +-- @ +-- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...] +-- @ +-- +-- @since 2.7.1 +mkEntityDefList + :: String + -- ^ The name that will be given to the 'EntityDef' list. + -> [UnboundEntityDef] + -> Q [Dec] +mkEntityDefList entityList entityDefs = do + let + entityListName = mkName entityList + edefs <- fmap ListE + . forM entityDefs + $ \entDef -> + let + entityType = entityDefConT entDef + in + [|entityDef (Proxy :: Proxy $(entityType))|] + typ <- [t|[EntityDef]|] + pure + [ SigD entityListName typ + , ValD (VarP entityListName) (NormalB edefs) [] + ] + +mkUniqueKeys :: UnboundEntityDef -> Q Dec +mkUniqueKeys def + | entitySum (unboundEntityDef def) = + return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] +mkUniqueKeys def = do + c <- clause + return $ FunD 'persistUniqueKeys [c] + where + clause = do + xs <- forM (getUnboundFieldDefs def) $ \fieldDef -> do + let + x = unboundFieldNameHS fieldDef + x' <- newName $ '_' : unpack (unFieldNameHS x) + return (x, x') + let + pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def + let + pat = + conp + (mkEntityDefName def) + (fmap (VarP . snd) xs) + return $ normalClause [pat] (ListE pcs) + + go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp + go xs (UniqueDef name _ cols _) = + List.foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols) + + go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp + go' xs front col = + let + col' = + fromMaybe + (error $ "failed in go' while looking up col=" <> show col) + (lookup col xs) + in + front `AppE` VarE col' + +sqlTypeFunD :: Exp -> Dec +sqlTypeFunD st = + FunD + 'sqlType + [normalClause [WildP] st] + +typeInstanceD + :: Name + -> Bool + -- ^ include PersistStore backend constraint + -> Type + -> [Dec] + -> Dec +typeInstanceD clazz hasBackend typ = + instanceD ctx (ConT clazz `AppT` typ) + where + ctx + | hasBackend = [mkClassP ''PersistStore [backendT]] + | otherwise = [] + +persistFieldInstanceD + :: Bool + -- ^ include PersistStore backend constraint + -> Type + -> [Dec] + -> Dec +persistFieldInstanceD = typeInstanceD ''PersistField + +persistFieldSqlInstanceD + :: Bool + -- ^ include PersistStore backend constraint + -> Type + -> [Dec] + -> Dec +persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql + +-- | Automatically creates a valid 'PersistField' instance for any datatype +-- that has valid 'Show' and 'Read' instances. Can be very convenient for +-- 'Enum' types. +derivePersistField :: String -> Q [Dec] +derivePersistField s = do + ss <- [|SqlString|] + tpv <- [|PersistText . pack . show|] + fpv <- + [| + \dt v -> + case fromPersistValue v of + Left e -> Left e + Right s' -> + case reads $ unpack s' of + (x, _) : _ -> Right x + [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s' + |] + return + [ persistFieldInstanceD + False + (ConT $ mkName s) + [ FunD + 'toPersistValue + [ normalClause [] tpv + ] + , FunD + 'fromPersistValue + [ normalClause [] (fpv `AppE` LitE (StringL s)) + ] + ] + , persistFieldSqlInstanceD + False + (ConT $ mkName s) + [ sqlTypeFunD ss + ] + ] + +-- | Automatically creates a valid 'PersistField' instance for any datatype +-- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it +-- generates instances similar to these: +-- +-- @ +-- instance PersistField T where +-- toPersistValue = PersistByteString . L.toStrict . encode +-- fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue +-- instance PersistFieldSql T where +-- sqlType _ = SqlString +-- @ +derivePersistFieldJSON :: String -> Q [Dec] +derivePersistFieldJSON s = do + ss <- [|SqlString|] + tpv <- [|PersistText . toJsonText|] + fpv <- + [| + \dt v -> do + text <- fromPersistValue v + let + bs' = TE.encodeUtf8 text + case eitherDecodeStrict' bs' of + Left e -> + Left $ + pack "JSON decoding error for " + ++ pack dt + ++ pack ": " + ++ pack e + ++ pack ". On Input: " + ++ decodeUtf8 bs' + Right x -> Right x + |] + return + [ persistFieldInstanceD + False + (ConT $ mkName s) + [ FunD + 'toPersistValue + [ normalClause [] tpv + ] + , FunD + 'fromPersistValue + [ normalClause [] (fpv `AppE` LitE (StringL s)) + ] + ] + , persistFieldSqlInstanceD + False + (ConT $ mkName s) + [ sqlTypeFunD ss + ] + ] + +-- | The basic function for migrating models, no Template Haskell required. +-- +-- It's probably best to use this in concert with 'mkEntityDefList', and then +-- call 'migrateModels' with the result from that function. +-- +-- @ +-- share [mkPersist sqlSettings, mkEntityDefList "entities"] [persistLowerCase| ... |] +-- +-- migrateAll = 'migrateModels' entities +-- @ +-- +-- The function 'mkMigrate' currently implements exactly this behavior now. If +-- you're splitting up the entity definitions into separate files, then it is +-- better to use the entity definition list and the concatenate all the models +-- together into a big list to call with 'migrateModels'. +-- +-- @ +-- module Foo where +-- +-- share [mkPersist s, mkEntityDefList "fooModels"] ... +-- +-- +-- module Bar where +-- +-- share [mkPersist s, mkEntityDefList "barModels"] ... +-- +-- module Migration where +-- +-- import Foo +-- import Bar +-- +-- migrateAll = migrateModels (fooModels <> barModels) +-- @ +-- +-- @since 2.13.0.0 +migrateModels :: [EntityDef] -> Migration +migrateModels defs = + forM_ (filter isMigrated defs) $ \def -> + migrate defs def + where + isMigrated def = pack "no-migrate" `notElem` entityAttrs def + +-- | Creates a single function to perform all migrations for the entities +-- defined here. One thing to be aware of is dependencies: if you have entities +-- with foreign references, make sure to place those definitions after the +-- entities they reference. +-- +-- In @persistent-2.13.0.0@, this was changed to *ignore* the input entity def +-- list, and instead defer to 'mkEntityDefList' to get the correct entities. +-- This avoids problems where the QuasiQuoter is unable to know what the right +-- reference types are. This sets 'mkPersist' to be the "single source of truth" +-- for entity definitions. +mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec] +mkMigrate fun eds = do + let + entityDefListName = ("entityDefListFor" <> fun) + body <- [|migrateModels $(varE (mkName entityDefListName))|] + edList <- mkEntityDefList entityDefListName eds + pure $ + edList + <> [ SigD (mkName fun) (ConT ''Migration) + , FunD (mkName fun) [normalClause [] body] + ] + +data EntityFieldTH = EntityFieldTH + { entityFieldTHCon :: Con + , entityFieldTHClause :: Clause + } + +-- Ent +-- fieldName FieldType +-- +-- forall . typ ~ FieldType => EntFieldName +-- +-- EntFieldName = FieldDef .... +-- +-- Field Def Accessors Required: +mkField + :: MkPersistSettings + -> EntityMap + -> UnboundEntityDef + -> UnboundFieldDef + -> Q EntityFieldTH +mkField mps entityMap et fieldDef = do + let + con = + ForallC + [] + [mkEqualP (VarT $ mkName "typ") fieldT] + $ NormalC name [] + fieldT = + maybeIdType mps entityMap fieldDef Nothing Nothing + bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef) + let + cla = + normalClause + [conp name []] + bod + return $ EntityFieldTH con cla + where + name = filterConName mps et fieldDef + +mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH +mkIdField mps ued = do + let + entityName = + getUnboundEntityNameHS ued + entityIdType + | mpsGeneric mps = + ConT ''Key + `AppT` ( ConT (mkEntityNameHSGenericName entityName) + `AppT` backendT + ) + | otherwise = + ConT $ mkName $ (T.unpack $ unEntityNameHS entityName) ++ "Id" + name = + filterConName' mps entityName (FieldNameHS "Id") + clause <- + fixPrimarySpec mps ued + pure + EntityFieldTH + { entityFieldTHCon = + ForallC + [] + [mkEqualP (VarT $ mkName "typ") entityIdType] + $ NormalC name [] + , entityFieldTHClause = + normalClause [conp name []] clause + } + +lookupEntityField + :: (PersistEntity entity) + => Proxy entity + -> FieldNameHS + -> FieldDef +lookupEntityField prxy fieldNameHS = + fromMaybe boom $ + List.find ((fieldNameHS ==) . fieldHaskell) $ + entityFields $ + entityDef prxy + where + boom = + error + "Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name" + +mkLookupEntityField + :: UnboundEntityDef + -> FieldNameHS + -> Q Exp +mkLookupEntityField ued ufd = + [| + lookupEntityField + (Proxy :: Proxy $(conT entityName)) + $(lift ufd) + |] + where + entityName = mkEntityNameHSName (getUnboundEntityNameHS ued) + +maybeNullable :: UnboundFieldDef -> Bool +maybeNullable fd = isUnboundFieldNullable fd == Nullable ByMaybeAttr + +ftToType :: FieldType -> Type +ftToType = \case + FTTypeCon Nothing t -> + ConT $ mkName $ T.unpack t + -- This type is generated from the Quasi-Quoter. + -- Adding this special case avoids users needing to import Data.Int + FTTypeCon (Just "Data.Int") "Int64" -> + ConT ''Int64 + FTTypeCon (Just m) t -> + ConT $ mkName $ unpack $ concat [m, ".", t] + FTLit l -> + LitT (typeLitToTyLit l) + FTTypePromoted t -> + PromotedT $ mkName $ T.unpack t + FTApp x y -> + ftToType x `AppT` ftToType y + FTList x -> + ListT `AppT` ftToType x + +typeLitToTyLit :: FieldTypeLit -> TyLit +typeLitToTyLit = \case + IntTypeLit n -> NumTyLit n + TextTypeLit t -> StrTyLit (T.unpack t) + +infixr 5 ++ +(++) :: (Monoid m) => m -> m -> m +(++) = mappend + +mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkJSON _ def | ("json" `notElem` entityAttrs (unboundEntityDef def)) = return [] +mkJSON mps (fixEntityDef -> def) = do + requireExtensions [[FlexibleInstances]] + pureE <- [|pure|] + apE' <- [|(<*>)|] + + let + objectE = VarE 'object + withObjectE = VarE 'withObject + dotEqualE = VarE '(.=) + dotColonE = VarE '(.:) + dotColonQE = VarE '(.:?) + toKeyE = aesonKeyFromString + obj <- newName "obj" + let + fields = + getUnboundFieldDefs def + + xs <- mapM fieldToJSONValName fields + + let + conName = + mkEntityDefName def + typ = + genericDataType mps (entityHaskell (unboundEntityDef def)) backendT + toJSONI = + typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] + where + toJSON' = + FunD 'toJSON $ + return $ + normalClause + [conp conName $ fmap VarP xs] + (objectE `AppE` ListE pairs) + where + pairs = zipWith toPair fields xs + toPair f x = + InfixE + ( Just + (toKeyE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f)) + ) + dotEqualE + (Just $ VarE x) + fromJSONI = + typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] + where + entNameStrLit = + StringL $ T.unpack (unEntityNameHS (getUnboundEntityNameHS def)) + parseJSONBody = + withObjectE `AppE` LitE entNameStrLit `AppE` decoderImpl + parseJSON' = + FunD 'parseJSON [normalClause [] parseJSONBody] + decoderImpl = + LamE + [VarP obj] + ( List.foldl' + (\x y -> InfixE (Just x) apE' (Just y)) + (pureE `AppE` ConE conName) + pulls + ) + where + pulls = + fmap toPull fields + toPull f = + InfixE + (Just $ VarE obj) + (if maybeNullable f then dotColonQE else dotColonE) + ( Just $ + AppE toKeyE $ + LitE $ + StringL $ + unpack $ + unFieldNameHS $ + unboundFieldNameHS f + ) + + case mpsEntityJSON mps of + Nothing -> + return [toJSONI, fromJSONI] + Just entityJSON -> do + entityJSONIs <- + if mpsGeneric mps + then + [d| + instance (PersistStore $(pure backendT)) => ToJSON (Entity $(pure typ)) where + toJSON = $(varE (entityToJSON entityJSON)) + + instance (PersistStore $(pure backendT)) => FromJSON (Entity $(pure typ)) where + parseJSON = $(varE (entityFromJSON entityJSON)) + |] + else + [d| + instance ToJSON (Entity $(pure typ)) where + toJSON = $(varE (entityToJSON entityJSON)) + + instance FromJSON (Entity $(pure typ)) where + parseJSON = $(varE (entityFromJSON entityJSON)) + |] + return $ toJSONI : fromJSONI : entityJSONIs + +#if MIN_VERSION_aeson(2,0,0) +aesonKeyFromString :: Exp +aesonKeyFromString = + VarE 'Key.fromString +#else +aesonKeyFromString :: Exp +aesonKeyFromString = + VarE 'pack +#endif + +mkClassP :: Name -> [Type] -> Pred +mkClassP cla tys = List.foldl AppT (ConT cla) tys + +mkEqualP :: Type -> Type -> Pred +mkEqualP tleft tright = List.foldl AppT EqualityT [tleft, tright] + +notStrict :: Bang +notStrict = Bang NoSourceUnpackedness NoSourceStrictness + +isStrict :: Bang +isStrict = Bang NoSourceUnpackedness SourceStrict + +instanceD :: Cxt -> Type -> [Dec] -> Dec +instanceD = InstanceD Nothing + +-- | Check that all of Persistent's required extensions are enabled, or else fail compilation +-- +-- This function should be called before any code that depends on one of the required extensions being enabled. +requirePersistentExtensions :: Q () +requirePersistentExtensions = requireExtensions requiredExtensions + where + requiredExtensions = + fmap + pure + [ DerivingStrategies + , GeneralizedNewtypeDeriving + , StandaloneDeriving + , UndecidableInstances + , MultiParamTypeClasses + ] + +mkSymbolToFieldInstances + :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] +mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do + let + entityHaskellName = + getEntityHaskellName $ unboundEntityDef ed + allFields = + getUnboundFieldDefs ed + mkEntityFieldConstr fieldHaskellName = + conE $ filterConName' mps entityHaskellName fieldHaskellName + :: Q Exp + regularFields <- forM (toList allFields) $ \fieldDef -> do + let + fieldHaskellName = + unboundFieldNameHS fieldDef + + let + fieldNameT :: Q Type + fieldNameT = + litT $ + strTyLit $ + T.unpack $ + lowerFirstIfId $ + unFieldNameHS fieldHaskellName + + lowerFirstIfId "Id" = "id" + lowerFirstIfId xs = xs + + fieldTypeT + | fieldHaskellName == FieldNameHS "Id" = + conT ''Key `appT` recordNameT + | otherwise = + pure $ maybeIdType mps entityMap fieldDef Nothing Nothing + entityFieldConstr = + mkEntityFieldConstr fieldHaskellName + mkInstance fieldNameT fieldTypeT entityFieldConstr + + mkey <- do + let + fieldHaskellName = + FieldNameHS "Id" + entityFieldConstr = + mkEntityFieldConstr fieldHaskellName + fieldTypeT = + conT ''Key `appT` recordNameT + mkInstance [t|"id"|] fieldTypeT entityFieldConstr + + pure (mkey <> join regularFields) + where + nameG = + mkEntityDefGenericName ed + recordNameT + | mpsGeneric mps = + conT nameG `appT` varT backendName + | otherwise = + entityDefConT ed + mkInstance fieldNameT fieldTypeT entityFieldConstr = + [d| + instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where + symbolToField = $(entityFieldConstr) + |] + +-- | Pass in a list of lists of extensions, where any of the given +-- extensions will satisfy it. For example, you might need either GADTs or +-- ExistentialQuantification, so you'd write: +-- +-- > requireExtensions [[GADTs, ExistentialQuantification]] +-- +-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd +-- write: +-- +-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] +requireExtensions :: [[Extension]] -> Q () +requireExtensions requiredExtensions = do + -- isExtEnabled breaks the persistent-template benchmark with the following error: + -- Template Haskell error: Can't do `isExtEnabled' in the IO monad + -- You can workaround this by replacing isExtEnabled with (pure . const True) + unenabledExtensions <- + filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions + + case mapMaybe listToMaybe unenabledExtensions of + [] -> pure () + [extension] -> + fail $ + mconcat + [ "Generating Persistent entities now requires the " + , show extension + , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n" + , extensionToPragma extension + ] + extensions -> + fail $ + mconcat + [ "Generating Persistent entities now requires the following language extensions:\n\n" + , List.intercalate "\n" (fmap show extensions) + , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" + , List.intercalate "\n" (fmap extensionToPragma extensions) + ] + where + extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" + +-- | creates a TH Name for use in the ToJSON instance +fieldToJSONValName :: UnboundFieldDef -> Q Name +fieldToJSONValName = + newName . T.unpack . unFieldNameHSForJSON . unboundFieldNameHS + +-- | This special-cases "type_" and strips out its underscore. When +-- used for JSON serialization and deserialization, it works around +-- +unFieldNameHSForJSON :: FieldNameHS -> Text +unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS + where + fixTypeUnderscore = \case + "type" -> "type_" + name -> name + +entityDefConK :: UnboundEntityDef -> Kind +entityDefConK = conK . mkEntityDefName + +entityDefConT :: UnboundEntityDef -> Q Type +entityDefConT = pure . entityDefConK + +entityDefConE :: UnboundEntityDef -> Exp +entityDefConE = ConE . mkEntityDefName + +-- | creates a TH Name for an entity's field, based on the entity +-- name and the field name, so for example: +-- +-- Customer +-- name Text +-- +-- This would generate `customerName` as a TH Name +fieldNameToRecordName + :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name +fieldNameToRecordName mps entDef fieldName = + mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName + where + mUnderscore + | mpsGenerateLenses mps = Just "_" + | otherwise = Nothing + +-- | as above, only takes a `FieldDef` +fieldDefToRecordName + :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name +fieldDefToRecordName mps entDef fieldDef = + fieldNameToRecordName mps entDef (unboundFieldNameHS fieldDef) + +-- | creates a TH Name for a lens on an entity's field, based on the entity +-- name and the field name, so as above but for the Lens +-- +-- Customer +-- name Text +-- +-- Generates a lens `customerName` when `mpsGenerateLenses` is true +-- while `fieldNameToRecordName` generates a prefixed function +-- `_customerName` +mkEntityLensName + :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name +mkEntityLensName mps entDef fieldDef = + mkRecordName + mps + Nothing + (entityHaskell (unboundEntityDef entDef)) + (unboundFieldNameHS fieldDef) + +mkRecordName + :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name +mkRecordName mps prefix entNameHS fieldNameHS = + mkName $ T.unpack . avoidKeyword $ fromMaybe "" prefix <> lowerFirst recName + where + recName :: Text + recName + | mpsPrefixFields mps = + mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) + | otherwise = fieldNameText + + entityNameText :: Text + entityNameText = + unEntityNameHS entNameHS + + fieldNameText :: Text + fieldNameText = + unFieldNameHS fieldNameHS + + avoidKeyword :: Text -> Text + avoidKeyword name = + if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name + +haskellKeywords :: Set.Set Text +haskellKeywords = + Set.fromList + [ "case" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "else" + , "if" + , "import" + , "in" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "module" + , "newtype" + , "of" + , "then" + , "type" + , "where" + , "_" + , "foreign" + ] + +-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` +mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name] +mkEntityDefDeriveNames mps entDef = + let + entityInstances = + mkName . T.unpack <$> entityDerives (unboundEntityDef entDef) + additionalInstances = + filter (`notElem` entityInstances) $ mpsDeriveInstances mps + in + entityInstances <> additionalInstances + +-- | Make a TH Name for the EntityDef's Haskell type +mkEntityNameHSName :: EntityNameHS -> Name +mkEntityNameHSName = + mkName . T.unpack . unEntityNameHS + +-- | As above only taking an `EntityDef` +mkEntityDefName :: UnboundEntityDef -> Name +mkEntityDefName = + mkEntityNameHSName . entityHaskell . unboundEntityDef + +-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric +mkEntityDefGenericName :: UnboundEntityDef -> Name +mkEntityDefGenericName = + mkEntityNameHSGenericName . entityHaskell . unboundEntityDef + +mkEntityNameHSGenericName :: EntityNameHS -> Name +mkEntityNameHSGenericName name = + mkName $ T.unpack (unEntityNameHS name <> "Generic") + +-- needs: +-- + +-- * entityHaskell + +-- * field on EntityDef + +-- * fieldHaskell + +-- * field on FieldDef +-- +sumConstrName + :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name +sumConstrName mps entDef unboundFieldDef = + mkName $ T.unpack name + where + name + | mpsPrefixFields mps = modifiedName ++ "Sum" + | otherwise = fieldName ++ "Sum" + fieldNameHS = + unboundFieldNameHS unboundFieldDef + modifiedName = + mpsConstraintLabelModifier mps entityName fieldName + entityName = + unEntityNameHS $ getUnboundEntityNameHS entDef + fieldName = + upperFirst $ unFieldNameHS fieldNameHS + +-- | Turn a ConstraintName into a TH Name +mkConstraintName :: ConstraintNameHS -> Name +mkConstraintName (ConstraintNameHS name) = + mkName (T.unpack name) + +keyIdName :: UnboundEntityDef -> Name +keyIdName = mkName . T.unpack . keyIdText + +keyIdText :: UnboundEntityDef -> Text +keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id" + +unKeyName :: UnboundEntityDef -> Name +unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef + +unKeyExp :: UnboundEntityDef -> Exp +unKeyExp ent = fieldSel (keyConName ent) (unKeyName ent) + +backendT :: Type +backendT = VarT backendName + +backendName :: Name +backendName = mkName "backend" + +-- needs: +-- + +-- * keyText + +-- * entityNameHaskell +-- * fields +-- * fieldHaskell +-- +-- keyConName :: EntityNameHS -> [FieldHaskell] -> Name +keyConName :: UnboundEntityDef -> Name +keyConName entDef = + keyConName' + (getUnboundEntityNameHS entDef) + (unboundFieldNameHS <$> unboundEntityFields (entDef)) + +keyConName' :: EntityNameHS -> [FieldNameHS] -> Name +keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName + where + resolveConflict kn = if conflict then kn `mappend` "'" else kn + conflict = any (== FieldNameHS "key") entFields + +-- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp +keyConExp :: UnboundEntityDef -> Exp +keyConExp ed = ConE $ keyConName ed + +keyText :: UnboundEntityDef -> Text +keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key" + +keyText' :: EntityNameHS -> Text +keyText' entName = unEntityNameHS entName ++ "Key" + +keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name +keyFieldName mps entDef fieldDef + | pkNewtype mps entDef = + unKeyName entDef + | otherwise = + mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` fieldName + where + fieldName = modifyFieldName (unFieldNameHS fieldDef) + modifyFieldName = + if mpsCamelCaseCompositeKeySelector mps then upperFirst else id + +filterConName + :: MkPersistSettings + -> UnboundEntityDef + -> UnboundFieldDef + -> Name +filterConName mps (unboundEntityDef -> entity) field = + filterConName' mps (entityHaskell entity) (unboundFieldNameHS field) + +filterConName' + :: MkPersistSettings + -> EntityNameHS + -> FieldNameHS + -> Name +filterConName' mps entity field = mkName $ T.unpack name + where + name + | field == FieldNameHS "Id" = entityName ++ fieldName + | mpsPrefixFields mps = modifiedName + | otherwise = fieldName + + modifiedName = mpsConstraintLabelModifier mps entityName fieldName + entityName = unEntityNameHS entity + fieldName = upperFirst $ unFieldNameHS field + +-- | +-- Splice in a list of all 'EntityDef' in scope. This is useful when running +-- 'mkPersist' to ensure that all entity definitions are available for setting +-- foreign keys, and for performing migrations with all entities available. +-- +-- 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to +-- account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. +-- +-- For example, +-- +-- @ +-- share +-- [ mkPersistWith sqlSettings $(discoverEntities) +-- ] +-- [persistLowerCase| ... |] +-- @ +-- +-- Likewise, to run migrations with all entity instances in scope, you'd write: +-- +-- @ +-- migrateAll = migrateModels $(discoverEntities) +-- @ +-- +-- Note that there is some odd behavior with Template Haskell and splicing +-- groups. If you call 'discoverEntities' in the same module that defines +-- 'PersistEntity' instances, you need to ensure they are in different top-level +-- binding groups. You can write @$(pure [])@ at the top level to do this. +-- +-- @ +-- -- Foo and Bar both export an instance of PersistEntity +-- import Foo +-- import Bar +-- +-- -- Since Foo and Bar are both imported, discoverEntities can find them here. +-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| +-- User +-- name Text +-- age Int +-- |] +-- +-- -- onlyFooBar is defined in the same 'top level group' as the above generated +-- -- instance for User, so it isn't present in this list. +-- onlyFooBar :: [EntityDef] +-- onlyFooBar = $(discoverEntities) +-- +-- -- We can manually create a new binding group with this, which splices an +-- -- empty list of declarations in. +-- \$(pure []) +-- +-- -- fooBarUser is able to see the 'User' instance. +-- fooBarUser :: [EntityDef] +-- fooBarUser = $(discoverEntities) +-- @ +-- +-- @since 2.13.0.0 +discoverEntities :: Q Exp +discoverEntities = do + instances <- reifyInstances ''PersistEntity [VarT (mkName "a")] + let + types = + mapMaybe getDecType instances + getDecType dec = + case dec of + InstanceD _moverlap [] typ _decs -> + stripPersistEntity typ + _ -> + Nothing + stripPersistEntity typ = + case typ of + AppT (ConT tyName) t + | tyName == ''PersistEntity -> + Just t + _ -> + Nothing + + fmap ListE $ + forM types $ \typ -> do + [e|entityDef (Proxy :: Proxy $(pure typ))|] + +setNull :: NonEmpty UnboundFieldDef -> Bool +setNull (fd :| fds) = + let + nullSetting = + isNull fd + isNull = + (NotNullable /=) . isUnboundFieldNullable + in + if all ((nullSetting ==) . isNull) fds + then nullSetting + else + error $ + "foreign key columns must all be nullable or non-nullable" + ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd : fds)) diff --git a/Database/Persist/Types.hs b/Database/Persist/Types.hs --- a/Database/Persist/Types.hs +++ b/Database/Persist/Types.hs @@ -1,6 +1,37 @@ +-- | This module exports many types and functions for operating on +-- @persistent@'s database representation. It's a bit of a kitchen sink. In the +-- future, this module will be reorganized, and many of the dependent modules +-- will be viewable on their own for easier documentation and organization. module Database.Persist.Types - ( module Database.Persist.Types.Base - , SomePersistField (..) + ( -- * Various Types of Names + + -- | There are so many kinds of names. @persistent@ defines newtype wrappers + -- for 'Text' so you don't confuse what a name is and what it is + -- supposed to be used for + module Database.Persist.Names + + -- * Database Definitions + + -- ** Entity/Table Definitions + + -- | The 'EntityDef' type is used by @persistent@ to generate Haskell code, + -- generate database migrations, and maintain metadata about entities. These + -- are generated in the call to 'Database.Persist.TH.mkPersist'. + , module Database.Persist.EntityDef + + -- ** Field definitions + + -- | The 'FieldDef' type is used to describe how a field should be + -- represented at the Haskell and database layers. + , module Database.Persist.FieldDef + + -- * Intermediate Values + + -- | The 'PersistValue' type is used as an intermediate layer between + -- database and Haskell types. + , module Database.Persist.PersistValue + + -- * Other Useful Stuff , Update (..) , BackendSpecificUpdate , SelectOpt (..) @@ -9,8 +40,50 @@ , BackendSpecificFilter , Key , Entity (..) + , OverflowNatural (..) + + -- * The rest of the types + , module Database.Persist.Types.Base ) where -import Database.Persist.Types.Base -import Database.Persist.Class.PersistField import Database.Persist.Class.PersistEntity +import Database.Persist.Class.PersistField +import Database.Persist.EntityDef +import Database.Persist.FieldDef +import Database.Persist.Names +import Database.Persist.PersistValue + +-- this module is a bit of a kitchen sink of types and concepts. the guts of +-- persistent, just strewn across the table. in 2.13 let's get this cleaned up +-- and a bit more tidy. +import Database.Persist.Types.Base + ( Attr + , CascadeAction (..) + , Checkmark (..) + , CompositeDef (..) + , EmbedEntityDef (..) + , EmbedFieldDef (..) + , ExtraLine + , FieldAttr (..) + , FieldCascade (..) + , FieldDef (..) + , FieldType (..) + , ForeignDef (..) + , ForeignFieldDef + , IsNullable (..) + , LiteralType (..) + , PersistException (..) + , PersistFilter (..) + , PersistUpdate (..) + , PersistValue (..) + , ReferenceDef (..) + , SqlType (..) + , UniqueDef (..) + , UpdateException (..) + , WhyNullable (..) + , fieldAttrsContainsNullable + , keyAndEntityFields + , keyAndEntityFieldsDatabase + , noCascade + , parseFieldAttrs + ) diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -1,33 +1,48 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass -module Database.Persist.Types.Base where +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import Control.Arrow (second) +module Database.Persist.Types.Base + ( module Database.Persist.Types.Base + + -- * Re-exports + , PersistValue (..) + , fromPersistValueText + , LiteralType (..) + , SourceSpan (..) + ) where + import Control.Exception (Exception) -import Control.Monad.Trans.Error (Error (..)) -import qualified Data.Aeson as A -import Data.Bits (shiftL, shiftR) -import Data.ByteString (ByteString, foldl') -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.HashMap.Strict as HM -import Data.Int (Int64) +import Data.Char (isSpace) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL import Data.Map (Map) -import qualified Data.Scientific -import Data.Text (Text, pack) +import Data.Maybe (isNothing) +import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) -import Data.Time (Day, TimeOfDay, UTCTime) -import Data.Typeable (Typeable) -import qualified Data.Vector as V import Data.Word (Word32) -import Numeric (showHex, readHex) -import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData) +import Language.Haskell.TH.Syntax (Lift (..)) +import Web.HttpApiData + ( FromHttpApiData (..) + , ToHttpApiData (..) + , parseBoundedTextData + , showTextData + ) +import Web.PathPieces (PathPiece (..)) +-- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` +-- instance on pre-1.2.4 versions of `text` +import Instances.TH.Lift () +import Database.Persist.Names +import Database.Persist.PersistValue +import Database.Persist.Types.SourceSpan (SourceSpan (..)) + -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of -- record may appear at most once, but other kinds of records may @@ -70,12 +85,13 @@ -- type available. Note that we never use @FALSE@, just @TRUE@ -- and @NULL@. Provides the same behavior @Maybe ()@ would if -- @()@ was a valid 'PersistField'. -data Checkmark = Active - -- ^ When used on a uniqueness constraint, there - -- may be at most one 'Active' record. - | Inactive - -- ^ When used on a uniqueness constraint, there - -- may be any number of 'Inactive' records. +data Checkmark + = -- | When used on a uniqueness constraint, there + -- may be at most one 'Active' record. + Active + | -- | When used on a uniqueness constraint, there + -- may be any number of 'Inactive' records. + Inactive deriving (Eq, Ord, Read, Show, Enum, Bounded) instance ToHttpApiData Checkmark where @@ -85,428 +101,649 @@ parseUrlPiece = parseBoundedTextData instance PathPiece Checkmark where - toPathPiece Active = "active" - toPathPiece Inactive = "inactive" + toPathPiece Active = "active" + toPathPiece Inactive = "inactive" - fromPathPiece "active" = Just Active - fromPathPiece "inactive" = Just Inactive - fromPathPiece _ = Nothing + fromPathPiece "active" = Just Active + fromPathPiece "inactive" = Just Inactive + fromPathPiece _ = Nothing -data IsNullable = Nullable !WhyNullable - | NotNullable - deriving (Eq, Show) +data IsNullable + = Nullable !WhyNullable + | NotNullable + deriving (Eq, Show) +fieldAttrsContainsNullable :: [FieldAttr] -> IsNullable +fieldAttrsContainsNullable s + | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr + | FieldAttrNullable `elem` s = Nullable ByNullableAttr + | otherwise = NotNullable -- | The reason why a field is 'nullable' is very important. A -- field that is nullable because of a @Maybe@ tag will have its -- type changed from @A@ to @Maybe A@. OTOH, a field that is -- nullable because of a @nullable@ tag will remain with the same -- type. -data WhyNullable = ByMaybeAttr - | ByNullableAttr - deriving (Eq, Show) +data WhyNullable + = ByMaybeAttr + | ByNullableAttr + deriving (Eq, Show) -- | An 'EntityDef' represents the information that @persistent@ knows -- about an Entity. It uses this information to generate the Haskell -- datatype, the SQL migrations, and other relevant conversions. data EntityDef = EntityDef - { entityHaskell :: !HaskellName + { entityHaskell :: !EntityNameHS -- ^ The name of the entity as Haskell understands it. - , entityDB :: !DBName + , entityDB :: !EntityNameDB -- ^ The name of the database table corresponding to the entity. - , entityId :: !FieldDef + , entityId :: !EntityIdDef -- ^ The entity's primary key or identifier. - , entityAttrs :: ![Attr] + , entityAttrs :: ![Attr] -- ^ The @persistent@ entity syntax allows you to add arbitrary 'Attr's -- to an entity using the @!@ operator. Those attributes are stored in -- this list. - , entityFields :: ![FieldDef] + , entityFields :: ![FieldDef] -- ^ The fields for this entity. Note that the ID field will not be -- present in this list. To get all of the fields for an entity, use -- 'keyAndEntityFields'. , entityUniques :: ![UniqueDef] -- ^ The Uniqueness constraints for this entity. - , entityForeigns:: ![ForeignDef] + , entityForeigns :: ![ForeignDef] -- ^ The foreign key relationships that this entity has to other -- entities. , entityDerives :: ![Text] -- ^ A list of type classes that have been derived for this entity. - , entityExtra :: !(Map Text [ExtraLine]) - , entitySum :: !Bool + , entityExtra :: !(Map Text [ExtraLine]) + , entitySum :: !Bool -- ^ Whether or not this entity represents a sum type in the database. , entityComments :: !(Maybe Text) -- ^ Optional comments on the entity. -- -- @since 2.10.0 + , entitySpan :: !(Maybe SourceSpan) + -- ^ Source code span occupied by this entity. May be absent if it is not + -- known. + -- + -- Note that until a refactor is completed, these cover the entire + -- persistent parser input rather than the particular entity in question. + -- + -- @since 2.15.0.0 } - deriving (Show, Eq, Read, Ord) + deriving (Show, Eq, Read, Ord, Lift) +-- | The definition for the entity's primary key ID. +-- +-- @since 2.13.0.0 +data EntityIdDef + = -- | The entity has a single key column, and it is a surrogate key - that + -- is, you can't go from @rec -> Key rec@. + -- + -- @since 2.13.0.0 + EntityIdField !FieldDef + | -- | The entity has a natural key. This means you can write @rec -> Key rec@ + -- because all the key fields are present on the datatype. + -- + -- A natural key can have one or more columns. + -- + -- @since 2.13.0.0 + EntityIdNaturalKey !CompositeDef + deriving (Show, Eq, Read, Ord, Lift) + +-- | Return the @['FieldDef']@ for the entity keys. +entitiesPrimary :: EntityDef -> NonEmpty FieldDef +entitiesPrimary t = + case entityId t of + EntityIdNaturalKey fds -> + compositeFields fds + EntityIdField fd -> + pure fd + entityPrimary :: EntityDef -> Maybe CompositeDef -entityPrimary t = case fieldReference (entityId t) of - CompositeRef c -> Just c - _ -> Nothing +entityPrimary t = + case entityId t of + EntityIdNaturalKey c -> + Just c + _ -> + Nothing -entityKeyFields :: EntityDef -> [FieldDef] -entityKeyFields ent = case entityPrimary ent of - Nothing -> [entityId ent] - Just pdef -> compositeFields pdef +entityKeyFields :: EntityDef -> NonEmpty FieldDef +entityKeyFields = + entitiesPrimary -keyAndEntityFields :: EntityDef -> [FieldDef] +-- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key +-- columns for an 'EntityDef'. +keyAndEntityFields :: EntityDef -> NonEmpty FieldDef keyAndEntityFields ent = - case entityPrimary ent of - Nothing -> entityId ent : entityFields ent - Just _ -> entityFields ent + keyWithFields (entityId ent) fields + where + fields = filter isHaskellField $ entityFields ent +-- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key +-- columns for an 'EntityDef' including those fields that are marked as +-- 'MigrationOnly' (and therefore only present in the database) or +-- 'SafeToRemove' (and a migration will drop the column if it exists in the +-- database). +-- +-- For fields on the Haskell type use 'keyAndEntityFieldsDatabase' +-- +-- @since 2.15.1.0 +keyAndEntityFieldsDatabase :: EntityDef -> NonEmpty FieldDef +keyAndEntityFieldsDatabase ent = + keyWithFields (entityId ent) fields + where + fields = entityFields ent -type ExtraLine = [Text] +keyWithFields :: EntityIdDef -> [FieldDef] -> NonEmpty FieldDef +keyWithFields entId fields = + case entId of + EntityIdField fd -> + fd :| fields + EntityIdNaturalKey _ -> + case NEL.nonEmpty fields of + Nothing -> + error $ + mconcat + [ "persistent internal guarantee failed: entity is " + , "defined with an entityId = EntityIdNaturalKey, " + , "but somehow doesn't have any entity fields." + ] + Just xs -> + xs -newtype HaskellName = HaskellName { unHaskellName :: Text } - deriving (Show, Eq, Read, Ord) -newtype DBName = DBName { unDBName :: Text } - deriving (Show, Eq, Read, Ord) +type ExtraLine = [Text] type Attr = Text +-- | Attributes that may be attached to fields that can affect migrations +-- and serialization in backend-specific ways. +-- +-- While we endeavor to, we can't forsee all use cases for all backends, +-- and so 'FieldAttr' is extensible through its constructor 'FieldAttrOther'. +-- +-- @since 2.11.0.0 +data FieldAttr + = -- | The 'Maybe' keyword goes after the type. This indicates that the column + -- is nullable, and the generated Haskell code will have a @'Maybe'@ type + -- for it. + -- + -- Example: + -- + -- @ + -- User + -- name Text Maybe + -- @ + FieldAttrMaybe + | -- | This indicates that the column is nullable, but should not have + -- a 'Maybe' type. For this to work out, you need to ensure that the + -- 'PersistField' instance for the type in question can support + -- a 'PersistNull' value. + -- + -- @ + -- data What = NoWhat | Hello Text + -- + -- instance PersistField What where + -- fromPersistValue PersistNull = + -- pure NoWhat + -- fromPersistValue pv = + -- Hello <$> fromPersistValue pv + -- + -- instance PersistFieldSql What where + -- sqlType _ = SqlString + -- + -- User + -- what What nullable + -- @ + FieldAttrNullable + | -- | This tag means that the column will not be present on the Haskell code, + -- but will not be removed from the database. Useful to deprecate fields in + -- phases. + -- + -- You should set the column to be nullable in the database. Otherwise, + -- inserts won't have values. + -- + -- @ + -- User + -- oldName Text MigrationOnly + -- newName Text + -- @ + FieldAttrMigrationOnly + | -- | A @SafeToRemove@ attribute is not present on the Haskell datatype, and + -- the backend migrations should attempt to drop the column without + -- triggering any unsafe migration warnings. + -- + -- Useful after you've used @MigrationOnly@ to remove a column from the + -- database in phases. + -- + -- @ + -- User + -- oldName Text SafeToRemove + -- newName Text + -- @ + FieldAttrSafeToRemove + | -- | This attribute indicates that we should not create a foreign key + -- reference from a column. By default, @persistent@ will try and create a + -- foreign key reference for a column if it can determine that the type of + -- the column is a @'Key' entity@ or an @EntityId@ and the @Entity@'s name + -- was present in 'mkPersist'. + -- + -- This is useful if you want to use the explicit foreign key syntax. + -- + -- @ + -- Post + -- title Text + -- + -- Comment + -- postId PostId noreference + -- Foreign Post fk_comment_post postId + -- @ + FieldAttrNoreference + | -- | This is set to specify precisely the database table the column refers + -- to. + -- + -- @ + -- Post + -- title Text + -- + -- Comment + -- postId PostId references="post" + -- @ + -- + -- You should not need this - @persistent@ should be capable of correctly + -- determining the target table's name. If you do need this, please file an + -- issue describing why. + FieldAttrReference Text + | -- | Specify a name for the constraint on the foreign key reference for this + -- table. + -- + -- @ + -- Post + -- title Text + -- + -- Comment + -- postId PostId constraint="my_cool_constraint_name" + -- @ + FieldAttrConstraint Text + | -- | Specify the default value for a column. + -- + -- @ + -- User + -- createdAt UTCTime default="NOW()" + -- @ + -- + -- Note that a @default=@ attribute does not mean you can omit the value + -- while inserting. + FieldAttrDefault Text + | -- | Specify a custom SQL type for the column. Generally, you should define + -- a custom datatype with a custom 'PersistFieldSql' instance instead of + -- using this. + -- + -- @ + -- User + -- uuid Text sqltype="UUID" + -- @ + FieldAttrSqltype Text + | -- | Set a maximum length for a column. Useful for VARCHAR and indexes. + -- + -- @ + -- User + -- name Text maxlen=200 + -- + -- UniqueName name + -- @ + FieldAttrMaxlen Integer + | -- | Specify the database name of the column. + -- + -- @ + -- User + -- blarghle Int sql="b_l_a_r_g_h_l_e" + -- @ + -- + -- Useful for performing phased migrations, where one column is renamed to + -- another column over time. + FieldAttrSql Text + | -- | A grab bag of random attributes that were unrecognized by the parser. + FieldAttrOther Text + deriving (Show, Eq, Read, Ord, Lift) + +-- | Parse raw field attributes into structured form. Any unrecognized +-- attributes will be preserved, identically as they are encountered, +-- as 'FieldAttrOther' values. +-- +-- @since 2.11.0.0 +parseFieldAttrs :: [Text] -> [FieldAttr] +parseFieldAttrs = fmap $ \case + "Maybe" -> FieldAttrMaybe + "nullable" -> FieldAttrNullable + "MigrationOnly" -> FieldAttrMigrationOnly + "SafeToRemove" -> FieldAttrSafeToRemove + "noreference" -> FieldAttrNoreference + raw + | Just x <- T.stripPrefix "reference=" raw -> FieldAttrReference x + | Just x <- T.stripPrefix "constraint=" raw -> FieldAttrConstraint x + | Just x <- T.stripPrefix "default=" raw -> FieldAttrDefault x + | Just x <- T.stripPrefix "sqltype=" raw -> FieldAttrSqltype x + | Just x <- T.stripPrefix "maxlen=" raw -> case reads (T.unpack x) of + [(n, s)] | all isSpace s -> FieldAttrMaxlen n + _ -> error $ "Could not parse maxlen field with value " <> show raw + | Just x <- T.stripPrefix "sql=" raw -> + FieldAttrSql x + | otherwise -> FieldAttrOther raw + +-- | A 'FieldType' describes a field parsed from the QuasiQuoter and is +-- used to determine the Haskell type in the generated code. +-- +-- @name Text@ parses into @FTTypeCon Nothing "Text"@ +-- +-- @name T.Text@ parses into @FTTypeCon (Just "T" "Text")@ +-- +-- @name (Jsonb User)@ parses into: +-- +-- @ +-- FTApp (FTTypeCon Nothing "Jsonb") (FTTypeCon Nothing "User") +-- @ data FieldType - = FTTypeCon (Maybe Text) Text - -- ^ Optional module and name. + = -- | Optional module and name. + FTTypeCon (Maybe Text) Text + | FTLit FieldTypeLit + | FTTypePromoted Text | FTApp FieldType FieldType | FTList FieldType - deriving (Show, Eq, Read, Ord) + deriving (Show, Eq, Read, Ord, Lift) --- | A 'FieldDef' represents the inormation that @persistent@ knows about --- a field of a datatype. This includes information used to parse the field --- out of the database and what the field corresponds to. -data FieldDef = FieldDef - { fieldHaskell :: !HaskellName - -- ^ The name of the field. Note that this does not corresponds to the - -- record labels generated for the particular entity - record labels - -- are generated with the type name prefixed to the field, so - -- a 'FieldDef' that contains a @'HaskellName' "name"@ for a type - -- @User@ will have a record field @userName@. - , fieldDB :: !DBName - -- ^ The name of the field in the database. For SQL databases, this - -- corresponds to the column name. - , fieldType :: !FieldType - -- ^ The type of the field in Haskell. - , fieldSqlType :: !SqlType - -- ^ The type of the field in a SQL database. - , fieldAttrs :: ![Attr] - -- ^ User annotations for a field. These are provided with the @!@ - -- operator. - , fieldStrict :: !Bool - -- ^ If this is 'True', then the Haskell datatype will have a strict - -- record field. The default value for this is 'True'. - , fieldReference :: !ReferenceDef - , fieldComments :: !(Maybe Text) - -- ^ Optional comments for a 'Field'. There is not currently a way to - -- attach comments to a field in the quasiquoter. - -- - -- @since 2.10.0 - } - deriving (Show, Eq, Read, Ord) +data FieldTypeLit + = IntTypeLit Integer + | TextTypeLit Text + deriving (Show, Eq, Read, Ord, Lift) +isFieldNotGenerated :: FieldDef -> Bool +isFieldNotGenerated = isNothing . fieldGenerated -- | There are 3 kinds of references -- 1) composite (to fields that exist in the record) -- 2) single field -- 3) embedded -data ReferenceDef = NoReference - | ForeignRef !HaskellName !FieldType - -- ^ A ForeignRef has a late binding to the EntityDef it references via HaskellName and has the Haskell type of the foreign key in the form of FieldType - | EmbedRef EmbedEntityDef - | CompositeRef CompositeDef - | SelfReference - -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311). - deriving (Show, Eq, Read, Ord) +data ReferenceDef + = NoReference + | -- | A ForeignRef has a late binding to the EntityDef it references via name + -- and has the Haskell type of the foreign key in the form of FieldType + ForeignRef !EntityNameHS + | EmbedRef EntityNameHS + | -- | A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311). + SelfReference + deriving (Show, Eq, Read, Ord, Lift) -- | An EmbedEntityDef is the same as an EntityDef -- But it is only used for fieldReference -- so it only has data needed for embedding data EmbedEntityDef = EmbedEntityDef - { embeddedHaskell :: !HaskellName - , embeddedFields :: ![EmbedFieldDef] - } deriving (Show, Eq, Read, Ord) + { embeddedHaskell :: EntityNameHS + , embeddedFields :: [EmbedFieldDef] + } + deriving (Show, Eq, Read, Ord, Lift) -- | An EmbedFieldDef is the same as a FieldDef -- But it is only used for embeddedFields -- so it only has data needed for embedding data EmbedFieldDef = EmbedFieldDef - { emFieldDB :: !DBName - , emFieldEmbed :: Maybe EmbedEntityDef - , emFieldCycle :: Maybe HaskellName - -- ^ 'emFieldEmbed' can create a cycle (issue #311) - -- when a cycle is detected, 'emFieldEmbed' will be Nothing - -- and 'emFieldCycle' will be Just + { emFieldDB :: FieldNameDB + , emFieldEmbed :: Maybe (Either SelfEmbed EntityNameHS) } - deriving (Show, Eq, Read, Ord) + deriving (Show, Eq, Read, Ord, Lift) +data SelfEmbed = SelfEmbed + deriving (Show, Eq, Read, Ord, Lift) + +-- | Returns 'True' if the 'FieldDef' does not have a 'MigrationOnly' or +-- 'SafeToRemove' flag from the QuasiQuoter. +-- +-- @since 2.13.0.0 +isHaskellField :: FieldDef -> Bool +isHaskellField fd = + FieldAttrMigrationOnly `notElem` fieldAttrs fd + && FieldAttrSafeToRemove `notElem` fieldAttrs fd + toEmbedEntityDef :: EntityDef -> EmbedEntityDef toEmbedEntityDef ent = embDef where - embDef = EmbedEntityDef - { embeddedHaskell = entityHaskell ent - , embeddedFields = map toEmbedFieldDef $ entityFields ent - } + embDef = + EmbedEntityDef + { embeddedHaskell = entityHaskell ent + , embeddedFields = + map toEmbedFieldDef $ + filter isHaskellField $ + entityFields ent + } toEmbedFieldDef :: FieldDef -> EmbedFieldDef toEmbedFieldDef field = - EmbedFieldDef { emFieldDB = fieldDB field - , emFieldEmbed = case fieldReference field of - EmbedRef em -> Just em - SelfReference -> Just embDef - _ -> Nothing - , emFieldCycle = case fieldReference field of - SelfReference -> Just $ entityHaskell ent - _ -> Nothing - } + EmbedFieldDef + { emFieldDB = + fieldDB field + , emFieldEmbed = + case fieldReference field of + EmbedRef em -> + Just $ Right em + SelfReference -> Just $ Left SelfEmbed + _ -> Nothing + } --- Type for storing the Uniqueness constraint in the Schema. --- Assume you have the following schema with a uniqueness --- constraint: +-- | Type for storing the Uniqueness constraint in the Schema. Assume you have +-- the following schema with a uniqueness constraint: +-- +-- @ -- Person -- name String -- age Int -- UniqueAge age +-- @ -- -- This will be represented as: --- UniqueDef (HaskellName (packPTH "UniqueAge")) --- (DBName (packPTH "unique_age")) [(HaskellName (packPTH "age"), DBName (packPTH "age"))] [] -- +-- @ +-- UniqueDef +-- { uniqueHaskell = ConstraintNameHS (packPTH "UniqueAge") +-- , uniqueDBName = ConstraintNameDB (packPTH "unique_age") +-- , uniqueFields = [(FieldNameHS (packPTH "age"), FieldNameDB (packPTH "age"))] +-- , uniqueAttrs = [] +-- } +-- @ data UniqueDef = UniqueDef - { uniqueHaskell :: !HaskellName - , uniqueDBName :: !DBName - , uniqueFields :: ![(HaskellName, DBName)] - , uniqueAttrs :: ![Attr] + { uniqueHaskell :: !ConstraintNameHS + , uniqueDBName :: !ConstraintNameDB + , uniqueFields :: !(NonEmpty (FieldNameHS, FieldNameDB)) + , uniqueAttrs :: ![Attr] } - deriving (Show, Eq, Read, Ord) + deriving (Show, Eq, Read, Ord, Lift) data CompositeDef = CompositeDef - { compositeFields :: ![FieldDef] - , compositeAttrs :: ![Attr] + { compositeFields :: !(NonEmpty FieldDef) + , compositeAttrs :: ![Attr] } - deriving (Show, Eq, Read, Ord) + deriving (Show, Eq, Read, Ord, Lift) -- | Used instead of FieldDef -- to generate a smaller amount of code -type ForeignFieldDef = (HaskellName, DBName) +type ForeignFieldDef = (FieldNameHS, FieldNameDB) data ForeignDef = ForeignDef - { foreignRefTableHaskell :: !HaskellName - , foreignRefTableDBName :: !DBName - , foreignConstraintNameHaskell :: !HaskellName - , foreignConstraintNameDBName :: !DBName - , foreignFields :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity - , foreignAttrs :: ![Attr] - , foreignNullable :: Bool + { foreignRefTableHaskell :: !EntityNameHS + , foreignRefTableDBName :: !EntityNameDB + , foreignConstraintNameHaskell :: !ConstraintNameHS + , foreignConstraintNameDBName :: !ConstraintNameDB + , foreignFieldCascade :: !FieldCascade + -- ^ Determine how the field will cascade on updates and deletions. + -- + -- @since 2.11.0 + , foreignFields :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity + , foreignAttrs :: ![Attr] + , foreignNullable :: Bool + , foreignToPrimary :: Bool + -- ^ Determines if the reference is towards a Primary Key or not. + -- + -- @since 2.11.0 } - deriving (Show, Eq, Read, Ord) - -data PersistException - = PersistError Text -- ^ Generic Exception - | PersistMarshalError Text - | PersistInvalidField Text - | PersistForeignConstraintUnmet Text - | PersistMongoDBError Text - | PersistMongoDBUnsupported Text - deriving (Show, Typeable) - -instance Exception PersistException -instance Error PersistException where - strMsg = PersistError . pack + deriving (Show, Eq, Read, Ord, Lift) --- | A raw value which can be stored in any backend and can be marshalled to --- and from a 'PersistField'. -data PersistValue = PersistText Text - | PersistByteString ByteString - | PersistInt64 Int64 - | PersistDouble Double - | PersistRational Rational - | PersistBool Bool - | PersistDay Day - | PersistTimeOfDay TimeOfDay - | PersistUTCTime UTCTime - | PersistNull - | PersistList [PersistValue] - | PersistMap [(Text, PersistValue)] - | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend - | PersistArray [PersistValue] -- ^ Intended especially for PostgreSQL backend for text arrays - | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend --- For example, below is a simple example of the PostGIS geography type: --- --- @ --- data Geo = Geo ByteString --- --- instance PersistField Geo where --- toPersistValue (Geo t) = PersistDbSpecific t --- --- fromPersistValue (PersistDbSpecific t) = Right $ Geo $ Data.ByteString.concat ["'", t, "'"] --- fromPersistValue _ = Left "Geo values must be converted from PersistDbSpecific" --- --- instance PersistFieldSql Geo where --- sqlType _ = SqlOther "GEOGRAPHY(POINT,4326)" --- --- toPoint :: Double -> Double -> Geo --- toPoint lat lon = Geo $ Data.ByteString.concat ["'POINT(", ps $ lon, " ", ps $ lat, ")'"] --- where ps = Data.Text.pack . show --- @ --- --- If Foo has a geography field, we can then perform insertions like the following: +-- | This datatype describes how a foreign reference field cascades deletes +-- or updates. -- --- @ --- insert $ Foo (toPoint 44 44) --- @ +-- This type is used in both parsing the model definitions and performing +-- migrations. A 'Nothing' in either of the field values means that the +-- user has not specified a 'CascadeAction'. An unspecified 'CascadeAction' +-- is defaulted to 'Restrict' when doing migrations. -- - deriving (Show, Read, Eq, Typeable, Ord) - - -instance ToHttpApiData PersistValue where - toUrlPiece val = - case fromPersistValueText val of - Left e -> error $ T.unpack e - Right y -> y - -instance FromHttpApiData PersistValue where - parseUrlPiece input = - PersistInt64 <$> parseUrlPiece input - PersistList <$> readTextData input - PersistText <$> return input - where - infixl 3 - Left _ y = y - x _ = x - -instance PathPiece PersistValue where - toPathPiece = toUrlPiece - fromPathPiece = parseUrlPieceMaybe - -fromPersistValueText :: PersistValue -> Either Text Text -fromPersistValueText (PersistText s) = Right s -fromPersistValueText (PersistByteString bs) = - Right $ TE.decodeUtf8With lenientDecode bs -fromPersistValueText (PersistInt64 i) = Right $ T.pack $ show i -fromPersistValueText (PersistDouble d) = Right $ T.pack $ show d -fromPersistValueText (PersistRational r) = Right $ T.pack $ show r -fromPersistValueText (PersistDay d) = Right $ T.pack $ show d -fromPersistValueText (PersistTimeOfDay d) = Right $ T.pack $ show d -fromPersistValueText (PersistUTCTime d) = Right $ T.pack $ show d -fromPersistValueText PersistNull = Left "Unexpected null" -fromPersistValueText (PersistBool b) = Right $ T.pack $ show b -fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" -fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" -fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" -fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text" -fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text. See the documentation of PersistDbSpecific for an example of using a custom database type with Persistent." - -instance A.ToJSON PersistValue where - toJSON (PersistText t) = A.String $ T.cons 's' t - toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b - toJSON (PersistInt64 i) = A.Number $ fromIntegral i - toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d - toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r - toJSON (PersistBool b) = A.Bool b - toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t - toJSON (PersistUTCTime u) = A.String $ T.pack $ 'u' : show u - toJSON (PersistDay d) = A.String $ T.pack $ 'd' : show d - toJSON PersistNull = A.Null - toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l - toJSON (PersistMap m) = A.object $ map (second A.toJSON) m - toJSON (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b - toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a - toJSON (PersistObjectId o) = - A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) "" - where - (four, eight) = BS8.splitAt 4 o +-- @since 2.11.0 +data FieldCascade = FieldCascade + { fcOnUpdate :: !(Maybe CascadeAction) + , fcOnDelete :: !(Maybe CascadeAction) + } + deriving (Show, Eq, Read, Ord, Lift) - -- taken from crypto-api - bs2i :: ByteString -> Integer - bs2i bs = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs - {-# INLINE bs2i #-} +-- | A 'FieldCascade' that does nothing. +-- +-- @since 2.11.0 +noCascade :: FieldCascade +noCascade = FieldCascade Nothing Nothing - -- showHex of n padded with leading zeros if necessary to fill d digits - -- taken from Data.BSON - showHexLen :: (Show n, Integral n) => Int -> n -> ShowS - showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n where - sigDigits 0 = 1 - sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1 +-- | Renders a 'FieldCascade' value such that it can be used in SQL +-- migrations. +-- +-- @since 2.11.0 +renderFieldCascade :: FieldCascade -> Text +renderFieldCascade (FieldCascade onUpdate onDelete) = + T.unwords + [ foldMap (mappend " ON DELETE " . renderCascadeAction) onDelete + , foldMap (mappend " ON UPDATE " . renderCascadeAction) onUpdate + ] -instance A.FromJSON PersistValue where - parseJSON (A.String t0) = - case T.uncons t0 of - Nothing -> fail "Null string" - Just ('p', t) -> either (\_ -> fail "Invalid base64") (return . PersistDbSpecific) - $ B64.decode $ TE.encodeUtf8 t - Just ('s', t) -> return $ PersistText t - Just ('b', t) -> either (\_ -> fail "Invalid base64") (return . PersistByteString) - $ B64.decode $ TE.encodeUtf8 t - Just ('t', t) -> fmap PersistTimeOfDay $ readMay t - Just ('u', t) -> fmap PersistUTCTime $ readMay t - Just ('d', t) -> fmap PersistDay $ readMay t - Just ('r', t) -> fmap PersistRational $ readMay t - Just ('o', t) -> maybe (fail "Invalid base64") (return . PersistObjectId) $ - fmap (i2bs (8 * 12) . fst) $ headMay $ readHex $ T.unpack t - Just (c, _) -> fail $ "Unknown prefix: " ++ [c] - where - headMay [] = Nothing - headMay (x:_) = Just x - readMay t = - case reads $ T.unpack t of - (x, _):_ -> return x - [] -> fail "Could not read" +-- | An action that might happen on a deletion or update on a foreign key +-- change. +-- +-- @since 2.11.0 +data CascadeAction = Cascade | Restrict | SetNull | SetDefault | NoAction + deriving (Show, Eq, Read, Ord, Lift) - -- taken from crypto-api - -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8). - i2bs :: Int -> Integer -> BS.ByteString - i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8) - {-# INLINE i2bs #-} +-- | Render a 'CascadeAction' to 'Text' such that it can be used in a SQL +-- command. +-- +-- @since 2.11.0 +renderCascadeAction :: CascadeAction -> Text +renderCascadeAction action = case action of + Cascade -> "CASCADE" + Restrict -> "RESTRICT" + SetNull -> "SET NULL" + SetDefault -> "SET DEFAULT" + NoAction -> "NO ACTION" +data PersistException + = -- | Generic Exception + PersistError Text + | PersistMarshalError Text + | PersistInvalidField Text + | PersistForeignConstraintUnmet Text + | PersistMongoDBError Text + | PersistMongoDBUnsupported Text + deriving (Show) - parseJSON (A.Number n) = return $ - if fromInteger (floor n) == n - then PersistInt64 $ floor n - else PersistDouble $ fromRational $ toRational n - parseJSON (A.Bool b) = return $ PersistBool b - parseJSON A.Null = return $ PersistNull - parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a) - parseJSON (A.Object o) = - fmap PersistMap $ mapM go $ HM.toList o - where - go (k, v) = fmap ((,) k) $ A.parseJSON v +instance Exception PersistException -- | A SQL data type. Naming attempts to reflect the underlying Haskell -- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may -- have different translations for these types. -data SqlType = SqlString - | SqlInt32 - | SqlInt64 - | SqlReal - | SqlNumeric Word32 Word32 - | SqlBool - | SqlDay - | SqlTime - | SqlDayTime -- ^ Always uses UTC timezone - | SqlBlob - | SqlOther T.Text -- ^ a backend-specific name - deriving (Show, Read, Eq, Typeable, Ord) +data SqlType + = SqlString + | SqlInt32 + | SqlInt64 + | SqlReal + | SqlNumeric Word32 Word32 + | SqlBool + | SqlDay + | SqlTime + | -- | Always uses UTC timezone + SqlDayTime + | SqlBlob + | -- | a backend-specific name + SqlOther T.Text + deriving (Show, Read, Eq, Ord, Lift) -data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn - | BackendSpecificFilter T.Text - deriving (Read, Show) +data PersistFilter + = Eq + | Ne + | Gt + | Lt + | Ge + | Le + | In + | NotIn + | BackendSpecificFilter T.Text + deriving (Read, Show, Lift) -data UpdateException = KeyNotFound String - | UpsertError String - deriving Typeable +data UpdateException + = KeyNotFound String + | UpsertError String instance Show UpdateException where show (KeyNotFound key) = "Key not found during updateGet: " ++ key show (UpsertError msg) = "Error during upsert: " ++ msg instance Exception UpdateException -data OnlyUniqueException = OnlyUniqueException String deriving Typeable +data OnlyUniqueException = OnlyUniqueException String instance Show OnlyUniqueException where show (OnlyUniqueException uniqueMsg) = - "Expected only one unique key, got " ++ uniqueMsg + "Expected only one unique key, got " ++ uniqueMsg instance Exception OnlyUniqueException +data PersistUpdate + = Assign + | Add + | Subtract + | Multiply + | Divide + | BackendSpecificUpdate T.Text + deriving (Read, Show, Lift) -data PersistUpdate = Assign | Add | Subtract | Multiply | Divide - | BackendSpecificUpdate T.Text - deriving (Read, Show) +-- | A 'FieldDef' represents the inormation that @persistent@ knows about +-- a field of a datatype. This includes information used to parse the field +-- out of the database and what the field corresponds to. +data FieldDef = FieldDef + { fieldHaskell :: !FieldNameHS + -- ^ The name of the field. Note that this does not corresponds to the + -- record labels generated for the particular entity - record labels + -- are generated with the type name prefixed to the field, so + -- a 'FieldDef' that contains a @'FieldNameHS' "name"@ for a type + -- @User@ will have a record field @userName@. + , fieldDB :: !FieldNameDB + -- ^ The name of the field in the database. For SQL databases, this + -- corresponds to the column name. + , fieldType :: !FieldType + -- ^ The type of the field in Haskell. + , fieldSqlType :: !SqlType + -- ^ The type of the field in a SQL database. + , fieldAttrs :: ![FieldAttr] + -- ^ User annotations for a field. These are provided with the @!@ + -- operator. + , fieldStrict :: !Bool + -- ^ If this is 'True', then the Haskell datatype will have a strict + -- record field. The default value for this is 'True'. + , fieldReference :: !ReferenceDef + , fieldCascade :: !FieldCascade + -- ^ Defines how operations on the field cascade on to the referenced + -- tables. This doesn't have any meaning if the 'fieldReference' is set + -- to 'NoReference' or 'SelfReference'. The cascade option here should + -- be the same as the one obtained in the 'fieldReference'. + -- + -- @since 2.11.0 + , fieldComments :: !(Maybe Text) + -- ^ Optional comments for a 'Field'. + -- + -- @since 2.10.0 + , fieldGenerated :: !(Maybe Text) + -- ^ Whether or not the field is a @GENERATED@ column, and additionally + -- the expression to use for generation. + -- + -- @since 2.11.0.0 + , fieldIsImplicitIdColumn :: !Bool + -- ^ 'True' if the field is an implicit ID column. 'False' otherwise. + -- + -- @since 2.13.0.0 + } + deriving (Show, Eq, Read, Ord, Lift) diff --git a/Database/Persist/Types/SourceSpan.hs b/Database/Persist/Types/SourceSpan.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Types/SourceSpan.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveLift #-} + +module Database.Persist.Types.SourceSpan (SourceSpan (..)) where + +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) + +-- | A pair of (start line/col, end line/col) coordinates. The end column will +-- be one past the final character (i.e. the span (1,1)->(1,1) is zero +-- characters long). +-- +-- SourceSpans are 1-indexed in both lines and columns. +-- +-- Conceptually identical to GHC's @RealSourceSpan@. +-- +-- @since 2.16.0.0 +data SourceSpan = SourceSpan + { spanFile :: !Text + , spanStartLine :: !Int + , spanStartCol :: !Int + , spanEndLine :: !Int + , spanEndCol :: !Int + } + deriving (Show, Eq, Read, Ord, Lift) diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main (main) where + +import Control.DeepSeq +import Criterion.Main +import Data.Text (Text) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Database.Persist.Quasi +import Database.Persist.TH +import Database.Persist.TH.Internal +import Models + +main :: IO () +main = + defaultMain + [ bgroup + "mkPersist" + [] + ] + +-- bench "From File" $ nfIO $ mkPersist' $(persistFileWith lowerCaseSettings "bench/models-slowly") +-- , bgroup "Non-Null Fields" +-- [ bgroup "Increasing model count" +-- [ bench "1x10" $ nfIO $ mkPersist' $( parseReferencesQ (mkModels 10 10)) +-- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10)) +-- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 100 10)) +-- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 1000 10)) +-- ] +-- , bgroup "Increasing field count" +-- [ bench "10x1" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1)) +-- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10)) +-- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 100)) +-- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1000)) +-- ] +-- ] +-- , bgroup "Nullable" +-- [ bgroup "Increasing model count" +-- [ bench "20x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 20 10)) +-- , bench "40x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 40 10)) +-- , bench "60x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 60 10)) +-- , bench "80x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 80 10)) +-- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 100 10)) +-- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 1000 10)) +-- ] +-- , bgroup "Increasing field count" +-- [ bench "10x20" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 20)) +-- , bench "10x40" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 40)) +-- , bench "10x60" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 60)) +-- , bench "10x80" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 80)) +-- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 100)) +-- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 1000)) +-- ] +-- ] + +-- Orphan instances for NFData Template Haskell types +instance NFData Overlap + +instance NFData AnnTarget + +instance NFData RuleBndr + +instance NFData Role + +instance NFData Phases + +instance NFData InjectivityAnn + +instance NFData FamilyResultSig + +instance NFData RuleMatch + +instance NFData TypeFamilyHead + +instance NFData TySynEqn + +instance NFData Inline + +instance NFData Pragma + +instance NFData FixityDirection + +instance NFData Safety + +instance NFData Fixity + +instance NFData Callconv + +instance NFData Foreign + +instance NFData SourceStrictness + +instance NFData SourceUnpackedness + +instance NFData FunDep + +instance NFData Bang + +#if MIN_VERSION_template_haskell(2,12,0) +instance NFData PatSynDir where + + +instance NFData PatSynArgs where + + +instance NFData DerivStrategy where + + +instance NFData DerivClause where +#endif + +#if MIN_VERSION_template_haskell(2,21,0) +instance NFData BndrVis where +#endif + +#if MIN_VERSION_template_haskell(2,22,0) +instance NFData NamespaceSpecifier where +#endif + +instance NFData Con + +instance NFData Range + +instance NFData Clause + +instance NFData PkgName + +instance NFData Dec + +instance NFData Stmt + +instance NFData TyLit + +instance NFData NameSpace + +instance NFData Body + +instance NFData Guard + +instance NFData Match + +instance NFData ModName + +instance NFData Pat + +#if MIN_VERSION_template_haskell(2,16,0) +instance NFData Bytes where + rnf !_ = () +#endif + +#if MIN_VERSION_template_haskell(2,17,0) +instance NFData a => NFData (TyVarBndr a) where + +instance NFData Specificity +#else +instance NFData TyVarBndr where + +#endif + +instance NFData NameFlavour + +instance NFData Type + +instance NFData Exp + +instance NFData Lit + +instance NFData OccName + +instance NFData Name diff --git a/bench/Models.hs b/bench/Models.hs new file mode 100644 --- /dev/null +++ b/bench/Models.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TupleSections #-} + +module Models where + +import Data.Monoid +import qualified Data.Text as Text +import Language.Haskell.TH + +import Database.Persist.Quasi +import Database.Persist.Quasi.Internal +import Database.Persist.Sql +import Database.Persist.TH +import Database.Persist.TH.Internal + +-- TODO: we use lookupName and reify etc which breaks in IO. somehow need to +-- test this out elsewise +mkPersist' :: [UnboundEntityDef] -> IO [Dec] +mkPersist' = runQ . mkPersist sqlSettings + +parseReferences' :: String -> IO Exp +parseReferences' = runQ . parseReferencesQ + +parseReferencesQ :: String -> Q Exp +parseReferencesQ = parseReferences lowerCaseSettings . pure . (Nothing,) . Text.pack + +-- | # of models, # of fields +mkModels :: Int -> Int -> String +mkModels = mkModelsWithFieldModifier id + +mkNullableModels :: Int -> Int -> String +mkNullableModels = mkModelsWithFieldModifier maybeFields + +mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String +mkModelsWithFieldModifier k i f = + unlines . fmap unlines . take i . map mkModel . zip [0 ..] . cycle $ + [ "Model" + , "Foobar" + , "User" + , "King" + , "Queen" + , "Dog" + , "Cat" + ] + where + mkModel :: (Int, String) -> [String] + mkModel (i', m) = + (m <> show i') : indent 4 (map k (mkFields f)) + +indent :: Int -> [String] -> [String] +indent i = map (replicate i ' ' ++) + +mkFields :: Int -> [String] +mkFields i = + take i $ + map mkField $ + zip [0 ..] $ + cycle + [ "Bool" + , "Int" + , "String" + , "Double" + , "Text" + ] + where + mkField :: (Int, String) -> String + mkField (i', typ) = "field" <> show i' <> "\t\t" <> typ + +maybeFields :: String -> String +maybeFields = (++ " Maybe") diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,124 +1,234 @@ -name: persistent -version: 2.10.5.4 -license: MIT -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman , Greg Weber -synopsis: Type-safe, multi-backend data serialization. -description: Hackage documentation generation is not reliable. For up to date documentation, please see: . -category: Database, Yesod -stability: Stable -cabal-version: >= 1.10 -build-type: Simple -homepage: http://www.yesodweb.com/book/persistent -bug-reports: https://github.com/yesodweb/persistent/issues -extra-source-files: ChangeLog.md README.md - -flag nooverlap - default: False - description: test out our assumption that OverlappingInstances is just for String +name: persistent +version: 2.18.1.0 +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: + Michael Snoyman , Greg Weber -library - if flag(nooverlap) - cpp-options: -DNO_OVERLAP +synopsis: Type-safe, multi-backend data serialization. +description: + Hackage documentation generation is not reliable. For up to date documentation, please see: . - build-depends: base >= 4.9 && < 5 - , aeson >= 1.0 - , attoparsec - , base64-bytestring - , blaze-html >= 0.9 - , bytestring >= 0.10 - , conduit >= 1.2.12 - , containers >= 0.5 - , fast-logger >= 2.4 - , http-api-data >= 0.3 - , monad-logger >= 0.3.28 - , mtl - , path-pieces >= 0.2 - , resource-pool >= 0.2.3 - , resourcet >= 1.1.10 - , scientific - , silently - , template-haskell - , text >= 1.2 - , time >= 1.6 - , transformers >= 0.5 - , unliftio-core - , unliftio - , unordered-containers - , vector +category: Database, Yesod +stability: Stable +cabal-version: >=1.10 +build-type: Simple +homepage: http://www.yesodweb.com/book/persistent +bug-reports: https://github.com/yesodweb/persistent/issues +extra-source-files: + ChangeLog.md + README.md - default-extensions: FlexibleContexts - , MultiParamTypeClasses - , OverloadedStrings - , TypeFamilies +library + default-language: Haskell2010 + build-depends: + aeson >=1.0 && <2.3 + , attoparsec + , attoparsec-aeson >=2.1.0.0 && <2.3 + , base >=4.11.1.0 && <5 + , base64-bytestring + , blaze-html >=0.9 + , bytestring >=0.10 + , conduit >=1.3 + , containers >=0.5 + , deepseq + , fast-logger >=2.4 + , http-api-data >=0.3 + , lift-type >=0.1.0.0 && <0.2.0.0 + , megaparsec + , monad-logger >=0.3.28 + , mtl + , path-pieces >=0.2 + , replace-megaparsec + , resource-pool >=0.2.3 + , resourcet >=1.1.10 + , scientific + , semigroupoids + , silently + , template-haskell >=2.13 && <2.24 + , text >=1.2 + , th-lift-instances >=0.1.14 && <0.2 + , time >=1.6 + , transformers >=0.5 + , unliftio + , unliftio-core + , unordered-containers + , vault + , vector - exposed-modules: Database.Persist - Database.Persist.Quasi + default-extensions: + FlexibleContexts + MultiParamTypeClasses + OverloadedStrings + TypeFamilies - Database.Persist.Types - Database.Persist.Class - Database.Persist.Sql - Database.Persist.Sql.Util - Database.Persist.Sql.Types.Internal + exposed-modules: + Database.Persist + Database.Persist.Class + Database.Persist.Class.PersistConfig + Database.Persist.Class.PersistEntity + Database.Persist.Class.PersistField + Database.Persist.Class.PersistQuery + Database.Persist.Class.PersistStore + Database.Persist.Class.PersistUnique + Database.Persist.EntityDef + Database.Persist.EntityDef.Internal + Database.Persist.FieldDef + Database.Persist.FieldDef.Internal + Database.Persist.ImplicitIdDef + Database.Persist.ImplicitIdDef.Internal + Database.Persist.Names + Database.Persist.PersistValue + Database.Persist.Quasi + 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 + Database.Persist.Sql.Util + Database.Persist.SqlBackend + Database.Persist.SqlBackend.Internal + Database.Persist.SqlBackend.Internal.InsertSqlResult + Database.Persist.SqlBackend.Internal.IsolationLevel + Database.Persist.SqlBackend.Internal.MkSqlBackend + Database.Persist.SqlBackend.Internal.SqlPoolHooks + Database.Persist.SqlBackend.Internal.Statement + Database.Persist.SqlBackend.Internal.StatementCache + Database.Persist.SqlBackend.SqlPoolHooks + Database.Persist.SqlBackend.StatementCache + Database.Persist.TH + Database.Persist.TH.Internal + Database.Persist.Types + Database.Persist.Types.SourceSpan - other-modules: Database.Persist.Types.Base - Database.Persist.Class.DeleteCascade - Database.Persist.Class.PersistEntity - Database.Persist.Class.PersistQuery - Database.Persist.Class.PersistUnique - Database.Persist.Class.PersistConfig - Database.Persist.Class.PersistField - Database.Persist.Class.PersistStore + other-modules: + Database.Persist.Sql.Class + Database.Persist.Sql.Internal + Database.Persist.Sql.Orphan.PersistQuery + Database.Persist.Sql.Orphan.PersistStore + Database.Persist.Sql.Orphan.PersistUnique + Database.Persist.Sql.Raw + Database.Persist.Sql.Run + Database.Persist.Sql.Types + Database.Persist.Types.Base - Database.Persist.Sql.Migration - Database.Persist.Sql.Internal - Database.Persist.Sql.Types - Database.Persist.Sql.Raw - Database.Persist.Sql.Run - Database.Persist.Sql.Class - Database.Persist.Sql.Orphan.PersistQuery - Database.Persist.Sql.Orphan.PersistStore - Database.Persist.Sql.Orphan.PersistUnique + -- These modules only make sense for compilers with access to DerivingVia + if impl(ghc >=8.6.1) + exposed-modules: Database.Persist.Compatible + other-modules: + Database.Persist.Compatible.TH + Database.Persist.Compatible.Types - ghc-options: -Wall + ghc-options: -Wall -Werror=incomplete-patterns default-language: Haskell2010 test-suite test - type: exitcode-stdio-1.0 - main-is: test/main.hs + type: exitcode-stdio-1.0 + main-is: main.hs + build-depends: + aeson + , attoparsec + , base >=4.9 && <5 + , base64-bytestring + , blaze-html + , bytestring + , conduit + , containers + , deepseq + , fast-logger + , hspec >=2.4 + , http-api-data + , megaparsec + , monad-logger + , mtl + , path-pieces + , persistent + , QuickCheck + , quickcheck-instances >=0.3 + , resource-pool + , resourcet + , scientific + , shakespeare + , silently + , template-haskell >=2.4 + , text + , th-lift-instances + , time + , transformers + , unliftio + , unliftio-core + , unordered-containers + , vector - build-depends: base >= 4.9 && < 5 - , aeson - , attoparsec - , base64-bytestring - , blaze-html - , bytestring - , containers - , hspec >= 2.4 - , http-api-data - , path-pieces - , scientific - , text - , time - , transformers - , unordered-containers - , vector + hs-source-dirs: test/ - cpp-options: -DTEST + -- don't warn on partial matches, they're all over the place in the + -- testsuite and if they crash they will just fail the test. + ghc-options: -Wall -Wno-incomplete-uni-patterns + default-extensions: + FlexibleContexts + MultiParamTypeClasses + OverloadedStrings + TypeFamilies + TypeOperators - default-extensions: FlexibleContexts - , MultiParamTypeClasses - , OverloadedStrings - , TypeFamilies + other-modules: + Database.Persist.ClassSpec + Database.Persist.PersistValueSpec + Database.Persist.QuasiSpec + Database.Persist.TH.CommentSpec + Database.Persist.TH.CompositeKeyStyleSpec + Database.Persist.TH.DiscoverEntitiesSpec + Database.Persist.TH.EmbedSpec + Database.Persist.TH.EntityHaddockSpec + Database.Persist.TH.ForeignRefSpec + Database.Persist.TH.ImplicitIdColSpec + Database.Persist.TH.JsonEncodingSpec + Database.Persist.TH.KindEntitiesSpec + Database.Persist.TH.KindEntitiesSpecImports + Database.Persist.TH.MaybeFieldDefsSpec + Database.Persist.TH.MigrationOnlySpec + Database.Persist.TH.MultiBlockSpec + Database.Persist.TH.MultiBlockSpec.Model + Database.Persist.TH.NestedSymbolsInTypeSpec + Database.Persist.TH.NestedSymbolsInTypeSpecImports + Database.Persist.TH.NoFieldSelectorsSpec + Database.Persist.TH.OverloadedLabelSpec + Database.Persist.TH.PersistWith.Model + Database.Persist.TH.PersistWith.Model2 + Database.Persist.TH.PersistWithSpec + Database.Persist.TH.RequireOnlyPersistImportSpec + Database.Persist.TH.SharedPrimaryKeyImportedSpec + Database.Persist.TH.SharedPrimaryKeySpec + Database.Persist.TH.SumSpec + Database.Persist.TH.ToFromPersistValuesSpec + Database.Persist.TH.TypeLitFieldDefsSpec + Database.Persist.THSpec + TemplateTestImports - other-modules: Database.Persist.Class.PersistEntity - Database.Persist.Class.PersistField - Database.Persist.Quasi - Database.Persist.Types - Database.Persist.Types.Base - default-language: Haskell2010 + default-language: Haskell2010 source-repository head type: git - location: git://github.com/yesodweb/persistent.git + location: https://github.com/yesodweb/persistent.git + +benchmark persistent-th-bench + ghc-options: -O2 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench + build-depends: + base + , criterion + , deepseq >=1.4 + , file-embed + , persistent + , template-haskell + , text + + other-modules: Models + default-language: Haskell2010 diff --git a/test/Database/Persist/ClassSpec.hs b/test/Database/Persist/ClassSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/ClassSpec.hs @@ -0,0 +1,23 @@ +module Database.Persist.ClassSpec where + +import Data.Time +import Database.Persist.Class +import Database.Persist.Types +import Test.Hspec + +spec :: Spec +spec = describe "Class" $ do + describe "PersistField" $ do + describe "UTCTime" $ do + it "fromPersistValue with ISO8601 format including UTC timezone Z (canonical)" $ + fromPersistValue (PersistText "2018-02-27T10:49:42.123Z") + `shouldBe` Right + (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) + it "fromPersistValue with ISO8601 format no timezone (backwards-compatibility)" $ + fromPersistValue (PersistText "2018-02-27T10:49:42.123") + `shouldBe` Right + (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) + it "fromPersistValue with pretty format (backwards-compatibility)" $ + fromPersistValue (PersistText "2018-02-27 10:49:42.123") + `shouldBe` Right + (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) diff --git a/test/Database/Persist/PersistValueSpec.hs b/test/Database/Persist/PersistValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/PersistValueSpec.hs @@ -0,0 +1,38 @@ +module Database.Persist.PersistValueSpec where + +import Data.Aeson +import qualified Data.ByteString.Char8 as BS8 +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import qualified Data.Text as T +import Database.Persist.PersistValue +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +spec :: Spec +spec = describe "PersistValueSpec" $ do + describe "PersistValue" $ do + describe "Aeson" $ do + let + testPrefix constr prefixChar bytes = + takePrefix (toJSON (constr (BS8.pack bytes))) + === String (T.singleton prefixChar) + roundTrip constr bytes = + fromJSON (toJSON (constr (BS8.pack bytes))) + === Data.Aeson.Success (constr (BS8.pack bytes)) + subject constr prefixChar = do + prop ("encodes with a " ++ [prefixChar] ++ " prefix") $ + testPrefix constr prefixChar + prop "Round Trips" $ + roundTrip constr + + describe "PersistDbSpecific" $ do + subject (PersistLiteral_ DbSpecific) 'p' + describe "PersistLiteral" $ do + subject PersistLiteral 'l' + describe "PersistLiteralEscaped" $ do + subject PersistLiteralEscaped 'e' + +takePrefix :: Value -> Value +takePrefix (String a) = String (T.take 1 a) +takePrefix a = a diff --git a/test/Database/Persist/QuasiSpec.hs b/test/Database/Persist/QuasiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/QuasiSpec.hs @@ -0,0 +1,1263 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Persist.QuasiSpec where + +import Prelude hiding (lines) + +import Control.Exception +import Data.Bifunctor +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Database.Persist.EntityDef.Internal +import Database.Persist.Quasi +import Database.Persist.Quasi.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.Megaparsec (errorBundlePretty, some) +import Text.Shakespeare.Text (st) + +defs :: T.Text -> [UnboundEntityDef] +defs = defsWithSettings lowerCaseSettings + +defsSnake :: T.Text -> [UnboundEntityDef] +defsSnake = defsWithSettings $ setPsUseSnakeCaseForeignKeys lowerCaseSettings + +defsWithWarnings + :: PersistSettings -> T.Text -> (Set ParserWarning, [UnboundEntityDef]) +defsWithWarnings ps t = case cpr of + (warnings, Right res) -> (warnings, res) + (_warnings, Left errs) -> error $ renderErrors errs + where + cpr = parse ps [(Nothing, t)] + +defsWithSettings :: PersistSettings -> T.Text -> [UnboundEntityDef] +defsWithSettings ps t = snd $ defsWithWarnings ps t + +#if MIN_VERSION_megaparsec(9,5,0) +warningSpecs :: Spec +warningSpecs = + describe "Quasi" $ 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 + 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 () +#endif + +spec :: Spec +spec = describe "Quasi" $ do + describe "takeColsEx" $ do + let + subject = takeColsEx upperCaseSettings + it "fails on a single word" $ do + subject ["asdf"] + `shouldBe` Nothing + it "errors on invalid input" $ do + evaluate (subject ["name", "int"]) + `shouldErrorWithMessage` "Invalid field type \"int\" PSFail \"int\"" + it "works if it has a name and a type" $ do + subject ["asdf", "Int"] + `shouldBe` Just + UnboundFieldDef + { unboundFieldNameHS = FieldNameHS "asdf" + , unboundFieldNameDB = FieldNameDB "asdf" + , unboundFieldType = FTTypeCon Nothing "Int" + , unboundFieldAttrs = [] + , unboundFieldStrict = True + , unboundFieldCascade = noCascade + , unboundFieldComments = Nothing + , unboundFieldGenerated = Nothing + } + it "works if it has a name, type, and cascade" $ do + subject ["asdf", "Int", "OnDeleteCascade", "OnUpdateCascade"] + `shouldBe` Just + UnboundFieldDef + { unboundFieldNameHS = FieldNameHS "asdf" + , unboundFieldNameDB = FieldNameDB "asdf" + , unboundFieldType = FTTypeCon Nothing "Int" + , unboundFieldAttrs = [] + , unboundFieldStrict = True + , unboundFieldCascade = FieldCascade (Just Cascade) (Just Cascade) + , unboundFieldComments = Nothing + , unboundFieldGenerated = Nothing + } + it "never tries to make a refernece" $ do + subject ["asdf", "UserId", "OnDeleteCascade"] + `shouldBe` Just + UnboundFieldDef + { unboundFieldNameHS = FieldNameHS "asdf" + , unboundFieldNameDB = FieldNameDB "asdf" + , unboundFieldType = FTTypeCon Nothing "UserId" + , unboundFieldAttrs = [] + , unboundFieldStrict = True + , unboundFieldCascade = FieldCascade Nothing (Just Cascade) + , unboundFieldComments = Nothing + , unboundFieldGenerated = Nothing + } + + describe "type parsing" $ do + let + 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" $ + 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" $ + parseAttributes "one (Finite 1)" + `shouldBe` ( [] + , Right + ( [ PText "one" + , Parenthetical "Finite 1" + ] + ) + ) + + it "handles quotes" $ + parseAttributes "abc=\"foo bar\" def=\"baz\"" + `shouldBe` ( [] + , Right + ( [ Assignment "abc" "foo bar" + , Assignment "def" "baz" + ] + ) + ) + + it "handles SQL literals with no specified type" $ + parseAttributes "attr='[\"ab\\'cd\", 1, 2]'" + `shouldBe` ( [] + , Right + ([Assignment "attr" "'[\"ab'cd\", 1, 2]'"]) + ) + + it "handles SQL literals with a specified type" $ + parseAttributes "attr='{\"\\'a\\'\": [1, 2.2, \"\\'3\\'\"]}'::type_name" + `shouldBe` ( [] + , Right + ([Assignment "attr" "'{\"'a'\": [1, 2.2, \"'3'\"]}'::type_name"]) + ) + + it "handles commas in tokens" $ + parseAttributes "x=COALESCE(left,right) baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "COALESCE(left,right)" + , PText "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" $ + parseAttributes "x=\"foo bar\" baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "foo bar" + , PText "baz" + ] + ) + ) + + it "handles escaped quotes mid-token" $ + parseAttributes "x=\\\"foo bar\" baz" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "\\\"foo" + , PText "bar\"" + , PText "baz" + ] + ) + ) + + it "handles unnested parentheses" $ + parseAttributes "(foo bar) (baz)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo bar" + , Parenthetical "baz" + ] + ) + ) + + it "handles unnested parentheses mid-token" $ + parseAttributes "x=(foo bar) (baz)" + `shouldBe` ( [] + , Right + ( [ Assignment "x" "foo bar" + , Parenthetical "baz" + ] + ) + ) + + it "handles nested parentheses" $ + parseAttributes "(foo (bar)) (baz)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo (bar)" + , Parenthetical "baz" + ] + ) + ) + + it "handles escaped quotation marks in plain tokens" $ + parseAttributes "foo bar\\\"baz" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar\\\"baz" + ] + ) + ) + + it "handles escaped quotation marks in quotations" $ + parseAttributes "foo bar=\"baz\\\"quux\"" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , Assignment "bar" "baz\"quux" + ] + ) + ) + + it "handles escaped quotation marks in equalities" $ + parseAttributes "y=\"baz\\\"\"" + `shouldBe` ( [] + , Right + ( [ Assignment "y" "baz\"" + ] + ) + ) + + it "handles escaped quotation marks in parentheticals" $ + parseAttributes "(foo \\\"bar)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo \\\"bar" + ] + ) + ) + + it "handles escaped parentheses in quotations" $ + parseAttributes "foo bar=\"baz\\(quux\"" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , Assignment "bar" "baz(quux" + ] + ) + ) + + it "handles escaped parentheses in plain tokens" $ + parseAttributes "foo bar\\(baz" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar(baz" + ] + ) + ) + + it "handles escaped parentheses in parentheticals" $ + parseAttributes "(foo \\(bar)" + `shouldBe` ( [] + , Right + ( [ Parenthetical "foo (bar" + ] + ) + ) + + it "handles escaped parentheses in equalities" $ + parseAttributes "y=baz\\(" + `shouldBe` ( [] + , Right + ( [ Assignment "y" "baz(" + ] + ) + ) + + it "handles mid-token quote in later token" $ + parseAttributes "foo bar baz=(bin\")" + `shouldBe` ( [] + , Right + ( [ PText "foo" + , PText "bar" + , Assignment "baz" "bin\"" + ] + ) + ) + + describe "entity field parsing" $ do + let + parseField :: String -> ParseResult () + parseField s = do + let + (warnings, res) = runConfiguredParser defaultPersistSettings initialExtraState entityField "" s + case res of + Left peb -> + (warnings, Left peb) + Right (_, _) -> (warnings, Right ()) + + it "should error if quotes are unterminated in an attribute" $ do + (fmap . first) errorBundlePretty (parseField "field String sql=\"foo bar") + `shouldBe` ( [] + , Left + ( "1:17:\n |\n1 | field String sql=\"foo bar\n | ^\nunexpected '='\nexpecting '!', '\"', ''', ',', '-', '.', ':', '[', '\\', ']', '_', '~', alphanumeric character, assignment expression, end of input, newline, parenthetical, or plain attribute\n" + ) + ) + + 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 + definitions = T.pack "User\n\tId Text\n\tname String" + + describe "when configured to permit tabs" $ do + let + (warnings, [user]) = defsWithWarnings lowerCaseSettings{psTabErrorLevel = Nothing} definitions + + it "permits tab indentation" $ + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + + describe "when configured to warn on tabs" $ do + 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 + definitions = T.pack "User\n name String \"Maybe\"" + + 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 + 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 = + [st| +Bicycle -- | this is a bike + brand String -- | the brand of the bike + ExtraBike + foo bar -- | this is a foo bar + baz + deriving Eq +-- | This is a Car +Car + -- | the make of the Car + make String + -- | the model of the Car + model String + UniqueModel model + deriving Eq Show ++Vehicle + bicycle BicycleId -- | the bike reference + car CarId -- | the car reference + + |] + let + [bicycle, car, vehicle] = defs subject + + it "should parse the `entityHaskell` field" $ do + getUnboundEntityNameHS bicycle `shouldBe` EntityNameHS "Bicycle" + getUnboundEntityNameHS car `shouldBe` EntityNameHS "Car" + getUnboundEntityNameHS vehicle `shouldBe` EntityNameHS "Vehicle" + + it "should parse the `entityDB` field" $ do + entityDB (unboundEntityDef bicycle) `shouldBe` EntityNameDB "bicycle" + entityDB (unboundEntityDef car) `shouldBe` EntityNameDB "car" + entityDB (unboundEntityDef vehicle) `shouldBe` EntityNameDB "vehicle" + + it "should parse the `entityAttrs` field" $ do + entityAttrs (unboundEntityDef bicycle) `shouldBe` [] + entityAttrs (unboundEntityDef car) `shouldBe` [] + entityAttrs (unboundEntityDef vehicle) `shouldBe` [] + + it "should parse the `unboundEntityFields` field" $ do + let + simplifyField field = + (unboundFieldNameHS field, unboundFieldNameDB field, unboundFieldComments field) + (simplifyField <$> unboundEntityFields bicycle) + `shouldBe` [ (FieldNameHS "brand", FieldNameDB "brand", Nothing) + ] + (simplifyField <$> unboundEntityFields car) + `shouldBe` [ (FieldNameHS "make", FieldNameDB "make", Just "the make of the Car\n") + , (FieldNameHS "model", FieldNameDB "model", Just "the model of the Car\n") + ] + (simplifyField <$> unboundEntityFields vehicle) + `shouldBe` [ (FieldNameHS "bicycle", FieldNameDB "bicycle", Nothing) + , (FieldNameHS "car", FieldNameDB "car", Nothing) + ] + + it "should parse the `entityUniques` field" $ do + let + simplifyUnique unique = + (uniqueHaskell unique, uniqueFields unique) + (simplifyUnique <$> entityUniques (unboundEntityDef bicycle)) `shouldBe` [] + (simplifyUnique <$> entityUniques (unboundEntityDef car)) + `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] = + defs + [st| +User + name Text + emailFirst Text + emailSecond Text + !yes Int + ~no Int + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + + Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond +|] + unboundForeignDefs user `shouldBe` [] + map unboundForeignDef (unboundForeignDefs notification) + `shouldBe` [ ForeignDef + { foreignRefTableHaskell = EntityNameHS "User" + , foreignRefTableDBName = EntityNameDB "user" + , foreignConstraintNameHaskell = ConstraintNameHS "fk_noti_user" + , foreignConstraintNameDBName = ConstraintNameDB "notificationfk_noti_user" + , foreignFieldCascade = FieldCascade Nothing Nothing + , foreignFields = + [] + , -- the foreign fields are not set yet in an unbound + -- entity def + foreignAttrs = [] + , foreignNullable = False + , foreignToPrimary = False + } + ] + + it "should parse the `entityDerives` field" $ do + entityDerives (unboundEntityDef bicycle) `shouldBe` ["Eq"] + entityDerives (unboundEntityDef car) `shouldBe` ["Eq", "Show"] + entityDerives (unboundEntityDef vehicle) `shouldBe` [] + + it "should parse the `entityEntities` field" $ do + entityExtra (unboundEntityDef bicycle) + `shouldBe` Map.singleton "ExtraBike" [["foo", "bar"], ["baz"]] + entityExtra (unboundEntityDef car) `shouldBe` mempty + entityExtra (unboundEntityDef vehicle) `shouldBe` mempty + + it "should parse the `entitySum` field" $ do + entitySum (unboundEntityDef bicycle) `shouldBe` False + entitySum (unboundEntityDef car) `shouldBe` False + entitySum (unboundEntityDef vehicle) `shouldBe` True + + it "should parse the `entityComments` field" $ do + entityComments (unboundEntityDef bicycle) `shouldBe` Nothing + entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n" + entityComments (unboundEntityDef vehicle) `shouldBe` Nothing + + it "should error on malformed input, unterminated parens" $ do + let + definitions = + [st| +User + name Text + age (Maybe Int +|] + let + [user] = defs definitions + evaluate (unboundEntityDef user) + `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 + definitions = + [st| +User + age Int OnUpdateCascade OnUpdateCascade +|] + let + [user] = defs definitions + mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) + `shouldErrorWithMessage` "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]" + + it "errors on duplicate cascade delete declarations" $ do + let + definitions = + [st| +User + age Int OnDeleteCascade OnDeleteCascade +|] + let + [user] = defs definitions + mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) + `shouldErrorWithMessage` "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]" + + describe "custom Id column" $ do + it "parses custom Id column" $ do + let + definitions = + [st| +User + Id Text + name Text + age Int +|] + let + [user] = defs definitions + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user" + let + idFields = NEL.toList (entitiesPrimary (unboundEntityDef user)) + (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"] + (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"] + (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"] + (unboundFieldNameHS <$> unboundEntityFields user) + `shouldBe` [ FieldNameHS "name" + , FieldNameHS "age" + ] + + it "errors on duplicate custom Id column" $ do + let + definitions = + [st| +User + Id Text + Id Text + name Text + age Int +|] + let + [user] = defs definitions + errMsg = [st|expected only one Id declaration per entity|] + evaluate (unboundEntityDef user) + `shouldErrorWithMessage` (T.unpack errMsg) + + describe "primary declaration" $ do + it "parses Primary declaration" $ do + let + definitions = + [st| +User + ref Text + name Text + age Int + Primary ref +|] + let + [user] = defs definitions + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user" + let + idFields = NEL.toList (entitiesPrimary (unboundEntityDef user)) + (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"] + (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"] + (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"] + (unboundFieldNameHS <$> unboundEntityFields user) + `shouldBe` [ FieldNameHS "ref" + , FieldNameHS "name" + , FieldNameHS "age" + ] + entityUniques (unboundEntityDef user) + `shouldBe` [ UniqueDef + { uniqueHaskell = + ConstraintNameHS "UserPrimaryKey" + , uniqueDBName = + ConstraintNameDB "primary_key" + , uniqueFields = + pure (FieldNameHS "ref", FieldNameDB "ref") + , uniqueAttrs = + [] + } + ] + + it "errors on duplicate custom Primary declaration" $ do + let + definitions = + [st| +User + ref Text + name Text + age Int + Primary ref + Primary name +|] + let + [user] = defs definitions + errMsg = "expected only one Primary declaration per entity" + evaluate (unboundEntityDef user) + `shouldErrorWithMessage` errMsg + + it "errors on conflicting Primary/Id declarations" $ do + let + definitions = + [st| +User + Id Text + ref Text + name Text + age Int + Primary ref +|] + let + [user] = defs definitions + errMsg = [st|Specified both an ID field and a Primary field|] + evaluate (unboundEntityDef user) + `shouldErrorWithMessage` (T.unpack errMsg) + + it "triggers error on invalid declaration" $ do + let + definitions = + [st| +User + age Text + Primary ref +|] + let + [user] = defs definitions + case unboundPrimarySpec user of + NaturalKey ucd -> do + evaluate (NEL.head $ unboundCompositeCols ucd) + `shouldErrorWithMessage` "Unknown column in primary key constraint: \"ref\"" + _ -> + error "Expected NaturalKey, failing" + + describe "entity unique constraints" $ do + it "triggers error if declared field does not exist" $ do + let + definitions = + [st| +User + name Text + emailFirst Text + + UniqueEmail emailFirst emailSecond +|] + let + [user] = defs definitions + uniques = entityUniques (unboundEntityDef user) + [dbNames] = fmap snd . uniqueFields <$> uniques + errMsg = + unwords + [ "Unknown column in \"UniqueEmail\" constraint: \"emailSecond\"" + , "possible fields: [\"name\",\"emailFirst\"]" + ] + evaluate (head (NEL.tail dbNames)) + `shouldErrorWithMessage` errMsg + + it "triggers error if no valid constraint name provided" $ do + let + definitions = + [st| +User + age Text + Unique some +|] + let + [user] = defs definitions + evaluate (unboundPrimarySpec user) + `shouldErrorWithMessage` "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]" + + describe "foreign keys" $ do + let + validDefinitions = + [st| +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 +|] + + it "should allow you to modify the FK name via provided function" $ do + let + flippedFK (EntityNameHS entName) (ConstraintNameHS conName) = + conName <> entName + [_user, notification] = defsWithSettings (setPsToFKName flippedFK lowerCaseSettings) validDefinitions + [notificationForeignDef] = + unboundForeignDef <$> unboundForeignDefs notification + foreignConstraintNameDBName notificationForeignDef + `shouldBe` ConstraintNameDB "fk_noti_user_notification" + + it "should error when insufficient params provided" $ do + let + definitions = + [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User +|] + let + [_user, notification] = defsSnake definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" + + it "should error when foreign fields not provided" $ do + let + definitions = + [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User fk_noti_user +|] + let + [_user, notification] = defsSnake definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldErrorWithMessage` "No fields on foreign reference." + + it "should error when number of parent and foreign fields differ" $ do + let + definitions = + [st| +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 +|] + let + [_user, notification] = defsSnake definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields" + + it + "should throw error when there is more than one delete cascade on the declaration" + $ do + let + definitions = + [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User OnDeleteCascade OnDeleteCascade +|] + let + [_user, notification] = defsSnake definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions" + + it + "should throw error when there is more than one update cascade on the declaration" + $ do + let + definitions = + [st| +User + name Text + emailFirst Text + emailSecond Text + + UniqueEmail emailFirst emailSecond + +Notification + content Text + sentToFirst Text + sentToSecond Text + Foreign User OnUpdateCascade OnUpdateCascade +|] + let + [_user, notification] = defsSnake definitions + mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) + `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions" + + it + "should allow you to enable snake cased foriegn keys via a preset configuration function" + $ do + let + [_user, notification] = + defsSnake validDefinitions + [notificationForeignDef] = + unboundForeignDef <$> unboundForeignDefs notification + foreignConstraintNameDBName notificationForeignDef + `shouldBe` ConstraintNameDB "notification_fk_noti_user" + + describe "ticked types" $ do + it "should be able to parse ticked types" $ do + let + simplifyField field = + (unboundFieldNameHS field, unboundFieldType field) + let + tickedDefinition = + [st| +CustomerTransfer + customerId CustomerId + moneyAmount (MoneyAmount 'Customer 'Debit) + currencyCode CurrencyCode + uuid TransferUuid +|] + let + [customerTransfer] = defs tickedDefinition + let + expectedType = + FTTypeCon Nothing "MoneyAmount" + `FTApp` FTTypePromoted "Customer" + `FTApp` FTTypePromoted "Debit" + + (simplifyField <$> unboundEntityFields customerTransfer) + `shouldBe` [ (FieldNameHS "customerId", FTTypeCon Nothing "CustomerId") + , (FieldNameHS "moneyAmount", expectedType) + , (FieldNameHS "currencyCode", FTTypeCon Nothing "CurrencyCode") + , (FieldNameHS "uuid", FTTypeCon Nothing "TransferUuid") + ] + + describe "type literals" $ do + it "should be able to parse type literals" $ do + let + simplifyField field = + (unboundFieldNameHS field, unboundFieldType field) + let + tickedDefinition = + [st| +WithFinite + one (Finite 1) + twenty (Labelled "twenty") +|] + let + [withFinite] = defs tickedDefinition + + (simplifyField <$> unboundEntityFields withFinite) + `shouldBe` [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))) + , + ( FieldNameHS "twenty" + , FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty")) + ) + ] + + describe "parseFieldType" $ do + it "simple types" $ + parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") + it "module types" $ + parseFieldType "Data.Map.FooBar" + `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar") + it "application" $ + parseFieldType "Foo Bar" + `shouldBe` Right + (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") + it "application multiple" $ + parseFieldType "Foo Bar Baz" + `shouldBe` Right + ( (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") + `FTApp` FTTypeCon Nothing "Baz" + ) + it "parens" $ do + let + foo = FTTypeCon Nothing "Foo" + bar = FTTypeCon Nothing "Bar" + baz = FTTypeCon Nothing "Baz" + parseFieldType "Foo (Bar Baz)" + `shouldBe` Right + (foo `FTApp` (bar `FTApp` baz)) + it "lists" $ do + let + foo = FTTypeCon Nothing "Foo" + bar = FTTypeCon Nothing "Bar" + bars = FTList bar + baz = FTTypeCon Nothing "Baz" + parseFieldType "Foo [Bar] Baz" + `shouldBe` Right + (foo `FTApp` bars `FTApp` baz) + it "numeric type literals" $ do + let + expected = FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1)) + parseFieldType "Finite 1" `shouldBe` Right expected + it "string type literals" $ do + let + expected = FTApp (FTTypeCon Nothing "Labelled") (FTLit (TextTypeLit "twenty")) + parseFieldType "Labelled \"twenty\"" `shouldBe` Right expected + it "nested list / parens (list inside parens)" $ do + let + maybeCon = FTTypeCon Nothing "Maybe" + int = FTTypeCon Nothing "Int" + parseFieldType "Maybe (Maybe [Int])" + `shouldBe` Right + (maybeCon `FTApp` (maybeCon `FTApp` FTList int)) + it "nested list / parens (parens inside list)" $ do + let + maybeCon = FTTypeCon Nothing "Maybe" + int = FTTypeCon Nothing "Int" + parseFieldType "[Maybe (Maybe Int)]" + `shouldBe` Right + (FTList (maybeCon `FTApp` (maybeCon `FTApp` int))) + it "fails on lowercase starts" $ do + parseFieldType "nothanks" `shouldBe` Left "PSFail \"nothanks\"" + + describe "#1175 empty entity" $ do + let + subject = + [st| +Foo + name String + age Int + +EmptyEntity + +Bar + name String + +Baz + a Int + b String + c FooId + |] + + it "parse works" $ do + let + test name'fieldCount parsedList = do + case (name'fieldCount, parsedList) of + ([], []) -> + pure () + ((name, fieldCount) : _, []) -> + expectationFailure $ + "Expected an entity with name " + <> name + <> " and " + <> show fieldCount + <> " fields" + <> ", but the list was empty..." + ((name, fieldCount) : ys, (x : xs)) -> do + let + UnboundEntityDef{..} = + x + (unEntityNameHS (getUnboundEntityNameHS x), length unboundEntityFields) + `shouldBe` (T.pack name, fieldCount) + test ys xs + ([], _ : _) -> + expectationFailure + "more entities parsed than expected" + + result = + defs subject + length result `shouldBe` 4 + + test + [ ("Foo", 2) + , ("EmptyEntity", 0) + , ("Bar", 1) + , ("Baz", 3) + ] + result + +arbitraryWhiteSpaceChar :: Gen Char +arbitraryWhiteSpaceChar = + oneof $ pure <$> [' ', '\t', '\n', '\r'] + +shouldErrorWithMessage :: IO a -> String -> Expectation +shouldErrorWithMessage action expectedMsg = do + res <- try action + case res of + Left (ErrorCall msg) -> + msg `shouldBe` expectedMsg + _ -> + expectationFailure "Expected `error` to have been called" diff --git a/test/Database/Persist/TH/CommentSpec.hs b/test/Database/Persist/TH/CommentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/CommentSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -haddock #-} + +module Database.Persist.TH.CommentSpec + ( CommentModel (..) + , spec + ) where + +import TemplateTestImports + +import Database.Persist.EntityDef.Internal (EntityDef (..)) +import Database.Persist.FieldDef.Internal (FieldDef (..)) + +mkPersist + (sqlSettings{mpsEntityHaddocks = True}) + [persistLowerCase| + +-- | Doc comments work. +-- | Has multiple lines. +CommentModel + -- | First line of comment on column. + -- | Second line of comment on column. + name String + + deriving Eq Show + +|] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +spec :: Spec +spec = describe "CommentSpec" $ do + let + ed = + entityDef (Proxy @CommentModel) + it "has entity comments" $ do + entityComments ed + `shouldBe` do + Just $ + mconcat + [ "Doc comments work.\n" + , "Has multiple lines.\n" + ] + + describe "fieldComments" $ do + let + [nameComments] = + map fieldComments $ entityFields ed + it "has the right name comments" $ do + nameComments + `shouldBe` do + Just $ + mconcat + [ "First line of comment on column.\n" + , "Second line of comment on column.\n" + ] diff --git a/test/Database/Persist/TH/CompositeKeyStyleSpec.hs b/test/Database/Persist/TH/CompositeKeyStyleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/CompositeKeyStyleSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} + +module Database.Persist.TH.CompositeKeyStyleSpec where + +import Data.Data (Data, constrFields, toConstr) +import Data.Text (Text) +import Database.Persist.Sql +import Database.Persist.TH +import Test.Hspec hiding (Selector) + +mkPersist + sqlSettings + [persistLowerCase| + CompanyUserLegacyStyle + companyName Text + userName Text + Primary companyName userName + |] + +deriving instance Data CompanyUserLegacyStyle +deriving instance Data (Key CompanyUserLegacyStyle) + +mkPersist + sqlSettings{mpsCamelCaseCompositeKeySelector = True} + [persistLowerCase| + CompanyUserCamelStyle + companyName Text + userName Text + Primary companyName userName + |] + +deriving instance Data CompanyUserCamelStyle +deriving instance Data (Key CompanyUserCamelStyle) + +spec :: Spec +spec = describe "CompositeKeyStyleSpec" $ do + describe "mpsCamelCaseCompositeKeySelector is False" $ do + it "Should generate Legacy style key selectors" $ do + let + key = CompanyUserLegacyStyleKey "cName" "uName" + + constrFields (toConstr key) + `shouldBe` [ "companyUserLegacyStyleKeycompanyName" + , "companyUserLegacyStyleKeyuserName" + ] + describe "mpsCamelCaseCompositeKeySelector is True" $ do + it "Should generate CamelCase style key selectors" $ do + let + key = CompanyUserCamelStyleKey "cName" "uName" + + constrFields (toConstr key) + `shouldBe` [ "companyUserCamelStyleKeyCompanyName" + , "companyUserCamelStyleKeyUserName" + ] diff --git a/test/Database/Persist/TH/DiscoverEntitiesSpec.hs b/test/Database/Persist/TH/DiscoverEntitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/DiscoverEntitiesSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.DiscoverEntitiesSpec where + +import TemplateTestImports + +import Data.Aeson + +import Data.Text (Text) + +import Language.Haskell.TH.Syntax + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +mkPersist + sqlSettings + [persistLowerCase| + +User + name String + age Int + +Dog + user UserId + name String + +Cat + enemy DogId + name String + +|] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +$(pure []) + +spec :: Spec +spec = describe "DiscoverEntitiesSpec" $ do + let + entities = $(discoverEntities) + it "should have all three entities" $ do + entities + `shouldMatchList` [ entityDef $ Proxy @User + , entityDef $ Proxy @Dog + , entityDef $ Proxy @Cat + ] diff --git a/test/Database/Persist/TH/EmbedSpec.hs b/test/Database/Persist/TH/EmbedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/EmbedSpec.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.EmbedSpec where + +import TemplateTestImports + +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T + +import Database.Persist.EntityDef +import Database.Persist.EntityDef.Internal (toEmbedEntityDef) +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) +import Database.Persist.Types + +mkPersist + sqlSettings + [persistLowerCase| + +Thing + name String + foo String MigrationOnly + + deriving Eq Show + +EmbedThing + someThing Thing + + deriving Eq Show + +SelfEmbed + name Text + self SelfEmbed Maybe + deriving Eq Show + +MutualEmbed + thing MutualTarget + +MutualTarget + thing [MutualEmbed] + +ModelWithList + names [Text] + +HasMap + map (M.Map T.Text T.Text) + deriving Show Eq Read Ord + +MapIdValue + map (M.Map T.Text (Key Thing)) + deriving Show Eq Read Ord + +|] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +spec :: Spec +spec = describe "EmbedSpec" $ do + describe "ModelWithList" $ do + let + edef = + entityDef $ Proxy @ModelWithList + [fieldDef] = + getEntityFields edef + it "has the right type" $ do + fieldType fieldDef + `shouldBe` FTList (FTTypeCon Nothing "Text") + it "has the right sqltype" $ do + fieldSqlType fieldDef + `shouldBe` SqlString + describe "MapIdValue" $ do + let + edef = + entityDef $ Proxy @MapIdValue + [fieldDef] = + getEntityFields edef + it "has the right type" $ do + fieldType fieldDef + `shouldBe` ( FTTypeCon (Just "M") "Map" + `FTApp` FTTypeCon (Just "T") "Text" + `FTApp` ( FTTypeCon Nothing "Key" + `FTApp` FTTypeCon Nothing "Thing" + ) + ) + it "has the right sqltype" $ do + fieldSqlType fieldDef + `shouldBe` SqlString + describe "HasMap" $ do + let + edef = + entityDef $ Proxy @HasMap + [fieldDef] = + getEntityFields edef + it "has the right type" $ do + fieldType fieldDef + `shouldBe` ( FTTypeCon (Just "M") "Map" + `FTApp` FTTypeCon (Just "T") "Text" + `FTApp` FTTypeCon (Just "T") "Text" + ) + it "has the right sqltype" $ do + fieldSqlType fieldDef + `shouldBe` SqlString + + describe "SomeThing" $ do + let + edef = + entityDef $ Proxy @Thing + describe "toEmbedEntityDef" $ do + let + embedDef = + toEmbedEntityDef edef + it "should have the same field count as Haskell fields" $ do + length (embeddedFields embedDef) + `shouldBe` length (getEntityFields edef) + + describe "EmbedThing" $ do + it "generates the right constructor" $ do + let + embedThing :: EmbedThing + embedThing = EmbedThing (Thing "asdf") + pass + + describe "SelfEmbed" $ do + let + edef = + entityDef $ Proxy @SelfEmbed + describe "fieldReference" $ do + let + [nameField, selfField] = getEntityFields edef + it "has self reference" $ do + fieldReference selfField + `shouldBe` NoReference + describe "toEmbedEntityDef" $ do + let + embedDef = + toEmbedEntityDef edef + it "has the same field count as regular def" $ do + length (getEntityFields edef) + `shouldBe` length (embeddedFields embedDef) diff --git a/test/Database/Persist/TH/EntityHaddockSpec.hs b/test/Database/Persist/TH/EntityHaddockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/EntityHaddockSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.Persist.TH.EntityHaddockSpec (spec) where + +import TemplateTestImports + +#if MIN_VERSION_template_haskell(2,18,0) +import Database.Persist.TH.CommentSpec (CommentModel (..)) +import Language.Haskell.TH (DocLoc (DeclDoc), getDoc) +import Language.Haskell.TH.Syntax (lift) + +[d| + commentModelDoc :: Maybe String + commentModelDoc = $(lift =<< getDoc (DeclDoc ''CommentModel)) + + commentFieldDoc :: Maybe String + commentFieldDoc = $(lift =<< getDoc (DeclDoc 'commentModelName)) + |] + +spec :: Spec +spec = describe "EntityHaddockSpec" $ do + it "generates entity Haddock" $ do + let expected = unlines [ "Doc comments work." + , "Has multiple lines." + ] + commentModelDoc `shouldBe` Just expected + it "generates field Haddock" $ do + let expected = unlines [ "First line of comment on column." + , "Second line of comment on column." + ] + commentFieldDoc `shouldBe` Just expected +#else +spec :: Spec +spec = pure () +#endif diff --git a/test/Database/Persist/TH/ForeignRefSpec.hs b/test/Database/Persist/TH/ForeignRefSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/ForeignRefSpec.hs @@ -0,0 +1,302 @@ +{-# 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 #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.ForeignRefSpec where + +import Control.Applicative (Const (..)) +import Data.Aeson +import Data.ByteString.Lazy.Char8 () +import Data.Coerce +import Data.Functor.Identity (Identity (..)) +import Data.Int +import qualified Data.List as List +import Data.Proxy +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen (Gen) + +import Database.Persist +import Database.Persist.EntityDef.Internal +import Database.Persist.Sql +import Database.Persist.Sql.Util +import Database.Persist.TH +import TemplateTestImports + +mkPersist + sqlSettings + [persistLowerCase| + +HasCustomName sql=custom_name + name Text + +ForeignTarget + name Text + deriving Eq Show + +ForeignSource + name Text + foreignTargetId ForeignTargetId + Foreign ForeignTarget fk_s_t foreignTargetId + +ForeignPrimary + name Text + Primary name + deriving Eq Show + +ForeignPrimarySource + name Text + Foreign ForeignPrimary fk_name_target name + +NullableRef + name Text Maybe + Foreign ForeignPrimary fk_nullable_ref name + +ParentImplicit + name Text + +ChildImplicit + name Text + parent ParentImplicitId OnDeleteCascade OnUpdateCascade + +ChildImplicitUnspecified + name Text + parent ParentImplicitId + +ChildImplicitNoAction + name Text + parent ParentImplicitId OnDeleteNoAction OnUpdateNoAction + +ParentExplicit + name Text + Primary name + +ChildExplicit + name Text + Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name + +ChildExplicitNoAction + name Text + Foreign ParentExplicit OnDeleteNoAction OnUpdateNoAction fkparent name + +ChildExplicitUnspecified + name Text + Foreign ParentExplicit fkparent name +|] + +spec :: Spec +spec = describe "ForeignRefSpec" $ do + describe "HasCustomName" $ do + let + edef = + entityDef $ Proxy @HasCustomName + it "should have a custom db name" $ do + entityDB edef + `shouldBe` EntityNameDB "custom_name" + + it "should compile" $ do + True `shouldBe` True + + describe "ForeignPrimarySource" $ do + let + fpsDef = + entityDef $ Proxy @ForeignPrimarySource + [foreignDef] = + entityForeigns fpsDef + it "has the right type" $ do + foreignPrimarySourceFk_name_target (ForeignPrimarySource "asdf") + `shouldBe` ForeignPrimaryKey "asdf" + + describe "Unspecified" $ do + describe "Explicit" $ do + let + parentDef = + entityDef $ Proxy @ParentExplicit + childDef = + entityDef $ Proxy @ChildExplicitUnspecified + childForeigns = + entityForeigns childDef + it "should have a single foreign reference defined" $ do + case entityForeigns childDef of + [ForeignDef{..}] -> + foreignFieldCascade + `shouldBe` FieldCascade + { fcOnUpdate = Nothing + , fcOnDelete = Nothing + } + as -> + expectationFailure . mconcat $ + [ "(Explicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] + + describe "Implicit" $ do + let + parentDef = + entityDef $ Proxy @ParentImplicit + childDef = + entityDef $ Proxy @ChildImplicitUnspecified + childFields = + entityFields childDef + describe "ChildImplicitUnspecified" $ do + case childFields of + [nameField, parentIdField] -> do + it "parentId has reference" $ do + fieldReference parentIdField + `shouldBe` ForeignRef (EntityNameHS "ParentImplicit") + fieldCascade parentIdField + `shouldBe` FieldCascade + { fcOnUpdate = Nothing + , fcOnDelete = Nothing + } + as -> + error . mconcat $ + [ "(Implicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] + + describe "NoAction" $ do + describe "Explicit" $ do + let + parentDef = + entityDef $ Proxy @ParentExplicit + childDef = + entityDef $ Proxy @ChildExplicitNoAction + childForeigns = + entityForeigns childDef + it "should have a single foreign reference defined" $ do + case entityForeigns childDef of + [ForeignDef{..}] -> + foreignFieldCascade + `shouldBe` FieldCascade + { fcOnUpdate = Just NoAction + , fcOnDelete = Just NoAction + } + as -> + expectationFailure . mconcat $ + [ "(Explicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] + + describe "Implicit" $ do + let + parentDef = + entityDef $ Proxy @ParentImplicit + childDef = + entityDef $ Proxy @ChildImplicitNoAction + childFields = + entityFields childDef + describe "ChildImplicitNoAction" $ do + case childFields of + [nameField, parentIdField] -> do + it "parentId has reference" $ do + fieldReference parentIdField + `shouldBe` ForeignRef (EntityNameHS "ParentImplicit") + fieldCascade parentIdField + `shouldBe` FieldCascade + { fcOnUpdate = Just NoAction + , fcOnDelete = Just NoAction + } + as -> + error . mconcat $ + [ "(Implicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] + + describe "Cascade" $ do + describe "Explicit" $ do + let + parentDef = + entityDef $ Proxy @ParentExplicit + childDef = + entityDef $ Proxy @ChildExplicit + childForeigns = + entityForeigns childDef + it "should have a single foreign reference defined" $ do + case entityForeigns childDef of + [ForeignDef{..}] -> + foreignFieldCascade + `shouldBe` FieldCascade + { fcOnUpdate = Just Cascade + , fcOnDelete = Just Cascade + } + as -> + expectationFailure . mconcat $ + [ "(Explicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] + let + [ForeignDef{..}] = + childForeigns + + describe "ChildExplicit" $ do + it "should have the right target table" $ do + 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 + } + it "is not nullable" $ do + foreignNullable `shouldBe` False + it "is to the Primary key" $ do + foreignToPrimary `shouldBe` True + + describe "Implicit" $ do + let + parentDef = + entityDef $ Proxy @ParentImplicit + childDef = + entityDef $ Proxy @ChildImplicit + childFields = + entityFields childDef + describe "ChildImplicit" $ do + case childFields of + [nameField, parentIdField] -> do + it "parentId has reference" $ do + fieldReference parentIdField + `shouldBe` ForeignRef (EntityNameHS "ParentImplicit") + fieldCascade parentIdField + `shouldBe` FieldCascade + { fcOnUpdate = Just Cascade + , fcOnDelete = Just Cascade + } + as -> + error . mconcat $ + [ "(Implicit) Expected one foreign reference on childDef, " + , "got: " + , show as + ] diff --git a/test/Database/Persist/TH/ImplicitIdColSpec.hs b/test/Database/Persist/TH/ImplicitIdColSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/ImplicitIdColSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.ImplicitIdColSpec where + +import TemplateTestImports + +import Data.Text (Text) + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) + +do + let + uuidDef = + mkImplicitIdDef @Text "uuid_generate_v1mc()" + settings = + setImplicitIdDef uuidDef sqlSettings + + mkPersist + settings + [persistLowerCase| + + User + name String + age Int + + |] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +spec :: Spec +spec = describe "ImplicitIdColSpec" $ do + describe "UserKey" $ do + it "has type Text -> Key User" $ do + let + userKey = UserKey "Hello" + _ = UserKey :: Text -> UserId + pass + + describe "getEntityId" $ do + let + EntityIdField idField = + getEntityId (entityDef (Nothing @User)) + it "has SqlString SqlType" $ asIO $ do + fieldSqlType idField `shouldBe` SqlString + it "has Text FieldType" $ asIO $ do + pendingWith "currently returns UserId, may not be an issue" + fieldType idField + `shouldBe` fieldTypeFromTypeable @Text diff --git a/test/Database/Persist/TH/JsonEncodingSpec.hs b/test/Database/Persist/TH/JsonEncodingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/JsonEncodingSpec.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.JsonEncodingSpec where + +import TemplateTestImports + +import Data.Aeson +import Data.Text (Text) +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Database.Persist.EntityDef +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) +import Database.Persist.Types + +mkPersist + sqlSettings + [persistLowerCase| +JsonEncoding json + name Text + age Int + Primary name + deriving Show Eq + +JsonEncoding2 json + name Text + age Int + blood Text + Primary name blood + deriving Show Eq + +JsonEncMigrationOnly json + name Text + age Int + foo Text MigrationOnly +|] + +instance Arbitrary JsonEncoding where + arbitrary = JsonEncoding <$> arbitrary <*> arbitrary + +instance Arbitrary JsonEncoding2 where + arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +spec :: Spec +spec = describe "JsonEncodingSpec" $ do + let + subject = + JsonEncoding "Bob" 32 + subjectEntity = + Entity (JsonEncodingKey (jsonEncodingName subject)) subject + + it "encodes without an ID field" $ do + toJSON subjectEntity + `shouldBe` object + [ ("name", String "Bob") + , ("age", toJSON (32 :: Int)) + , ("id", String "Bob") + ] + + it "decodes without an ID field" $ do + let + json_ = + encode . object $ + [ ("name", String "Bob") + , ("age", toJSON (32 :: Int)) + ] + eitherDecode json_ + `shouldBe` Right subjectEntity + + it "has informative decoder errors" $ do + let + json_ = encode Null + (eitherDecode json_ :: Either String JsonEncoding) + `shouldBe` Left + "Error in $: parsing JsonEncoding failed, expected Object, but encountered Null" + + prop "works with a Primary" $ \jsonEncoding -> do + let + ent = + Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding + decode (encode ent) + `shouldBe` Just ent + + prop "excuse me what" $ \j@JsonEncoding{..} -> do + let + ent = + Entity (JsonEncodingKey jsonEncodingName) j + toJSON ent + `shouldBe` object + [ ("name", toJSON jsonEncodingName) + , ("age", toJSON jsonEncodingAge) + , ("id", toJSON jsonEncodingName) + ] + + prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do + let + key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood + ent = + Entity key j + decode (encode ent) + `shouldBe` Just ent + + prop "works with a composite key" $ \j@JsonEncoding2{..} -> do + let + key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood + ent = + Entity key j + toJSON ent + `shouldBe` object + [ ("name", toJSON jsonEncoding2Name) + , ("age", toJSON jsonEncoding2Age) + , ("blood", toJSON jsonEncoding2Blood) + , ("id", toJSON key) + ] diff --git a/test/Database/Persist/TH/KindEntitiesSpec.hs b/test/Database/Persist/TH/KindEntitiesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/KindEntitiesSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.KindEntitiesSpec where + +import Database.Persist.TH.KindEntitiesSpecImports +import TemplateTestImports + +mkPersist + sqlSettings + [persistLowerCase| + +Customer + name String + age Int + +CustomerTransfer + customerId CustomerId + moneyAmount (MoneyAmount 'CustomerOwned 'Debit) +|] + +spec :: Spec +spec = describe "KindEntities" $ do + it "should support DataKinds in entity definition" $ do + let + mkTransfer + :: CustomerId -> MoneyAmount 'CustomerOwned 'Debit -> CustomerTransfer + mkTransfer = CustomerTransfer + getAmount :: CustomerTransfer -> MoneyAmount 'CustomerOwned 'Debit + getAmount = customerTransferMoneyAmount + compiles + +compiles :: Expectation +compiles = True `shouldBe` True diff --git a/test/Database/Persist/TH/KindEntitiesSpecImports.hs b/test/Database/Persist/TH/KindEntitiesSpecImports.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/KindEntitiesSpecImports.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Database.Persist.TH.KindEntitiesSpecImports where + +import Data.Proxy +import qualified Data.Text as T +import TemplateTestImports + +data Owner = MerchantOwned | CustomerOwned +data AccountKind = Debit | Credit + +newtype MoneyAmount (a :: Owner) (b :: AccountKind) = MoneyAmount Rational + +instance PersistFieldSql (MoneyAmount a b) where + sqlType _ = sqlType (Proxy :: Proxy Rational) + +instance PersistField (MoneyAmount a b) where + toPersistValue (MoneyAmount n) = + toPersistValue n + fromPersistValue v = + MoneyAmount <$> fromPersistValue v diff --git a/test/Database/Persist/TH/MaybeFieldDefsSpec.hs b/test/Database/Persist/TH/MaybeFieldDefsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/MaybeFieldDefsSpec.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.MaybeFieldDefsSpec where + +import TemplateTestImports + +mkPersist + sqlSettings + [persistLowerCase| +Account + name (Maybe String) + email String +|] + +spec :: Spec +spec = describe "MaybeFieldDefs" $ do + it "should support literal `Maybe` declaration in entity definition" $ do + let + mkAccount :: Maybe String -> String -> Account + mkAccount = Account + compiles + +compiles :: Expectation +compiles = True `shouldBe` True diff --git a/test/Database/Persist/TH/MigrationOnlySpec.hs b/test/Database/Persist/TH/MigrationOnlySpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/MigrationOnlySpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.MigrationOnlySpec where + +import TemplateTestImports + +import Data.Text (Text) + +import Database.Persist.ImplicitIdDef +import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) +import Database.Persist.Types + +mkPersist + sqlSettings + [persistLowerCase| + +HasMigrationOnly + name String + blargh Int MigrationOnly + + deriving Eq Show +|] + +pass :: IO () +pass = pure () + +asIO :: IO a -> IO a +asIO = id + +spec :: Spec +spec = describe "MigrationOnlySpec" $ do + describe "HasMigrationOnly" $ do + let + edef = + entityDef $ Proxy @HasMigrationOnly + describe "getEntityFields" $ do + it "has one field" $ do + length (getEntityFields edef) + `shouldBe` 1 + describe "getEntityFieldsDatabase" $ do + it "has two fields" $ do + length (getEntityFieldsDatabase edef) + `shouldBe` 2 + describe "toPersistFields" $ do + it "should have one field" $ do + map toPersistValue (toPersistFields (HasMigrationOnly "asdf")) + `shouldBe` [PersistText ("asdf" :: Text)] + describe "fromPersistValues" $ do + it "should work with only item in list" $ do + fromPersistValues [PersistText "Hello"] + `shouldBe` Right (HasMigrationOnly "Hello") diff --git a/test/Database/Persist/TH/MultiBlockSpec.hs b/test/Database/Persist/TH/MultiBlockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/MultiBlockSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.MultiBlockSpec where + +import TemplateTestImports + +import Database.Persist.TH.MultiBlockSpec.Model + +share + [ mkPersistWith sqlSettings importDefList + ] + [persistLowerCase| + +Thing + name Text + Primary name + +ThingAuto + name Text + +MBBar + name Text + age Int + user UserId + thing ThingId + thingAuto ThingAutoId + profile MBDogId + + Foreign MBCompositePrimary bar_to_comp name age +|] + +spec :: Spec +spec = describe "MultiBlockSpec" $ do + describe "MBBar" $ do + let + edef = + entityDef $ Proxy @MBBar + describe "Foreign Key Works" $ do + let + [n, a, userRef, thingRef, thingAutoRef, profileRef] = + getEntityFields edef + it "User reference works" $ do + fieldReference userRef + `shouldBe` ForeignRef + (EntityNameHS "User") + + it "Primary key reference works" $ do + fieldReference profileRef + `shouldBe` ForeignRef + (EntityNameHS "MBDog") + + it "Thing ref works (same block)" $ do + fieldReference thingRef + `shouldBe` ForeignRef + (EntityNameHS "Thing") + + it "ThingAuto ref works (same block)" $ do + fieldReference thingAutoRef + `shouldBe` ForeignRef + (EntityNameHS "ThingAuto") diff --git a/test/Database/Persist/TH/MultiBlockSpec/Model.hs b/test/Database/Persist/TH/MultiBlockSpec/Model.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/MultiBlockSpec/Model.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.MultiBlockSpec.Model where + +import TemplateTestImports + +share + [ mkPersist sqlSettings + , mkEntityDefList "importDefList" + ] + [persistLowerCase| + +User + name Text + age Int + + deriving Eq Show + +MBDog + name Text + Primary name + +MBCompositePrimary + name Text + age Int + + Primary name age + +|] diff --git a/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs b/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + +module Database.Persist.TH.NestedSymbolsInTypeSpec where + +import Data.Map +import Database.Persist.TH.NestedSymbolsInTypeSpecImports +import TemplateTestImports + +mkPersist + sqlSettings + [persistLowerCase| +PathEntitySimple + readOnly (Maybe (SomePath ReadOnly)) + +PathEntityNested + paths (Maybe (Map Text [SomePath ReadWrite])) +|] + +spec :: Spec +spec = describe "NestedSymbolsInType" $ do + it "should support nested parens" $ do + let + mkPathEntitySimple :: Maybe (SomePath ReadOnly) -> PathEntitySimple + mkPathEntitySimple = PathEntitySimple + pathEntitySimpleReadOnly' :: PathEntitySimple -> Maybe (SomePath ReadOnly) + pathEntitySimpleReadOnly' = pathEntitySimpleReadOnly + compiles + + it "should support deeply nested parens + square brackets" $ do + let + mkPathEntityNested :: Maybe (Map Text [SomePath ReadWrite]) -> PathEntityNested + mkPathEntityNested = PathEntityNested + pathEntityNestedPaths' + :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite]) + pathEntityNestedPaths' = pathEntityNestedPaths + compiles + +compiles :: Expectation +compiles = True `shouldBe` True diff --git a/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs b/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} + +module Database.Persist.TH.NestedSymbolsInTypeSpecImports where + +import Data.Proxy +import TemplateTestImports + +data ReadOnly +data ReadWrite + +newtype SomePath a = SomePath Text + +instance PersistFieldSql (SomePath a) where + sqlType _ = SqlString + +instance PersistField (SomePath a) where + toPersistValue (SomePath n) = + toPersistValue n + fromPersistValue v = + SomePath <$> fromPersistValue v diff --git a/test/Database/Persist/TH/NoFieldSelectorsSpec.hs b/test/Database/Persist/TH/NoFieldSelectorsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/NoFieldSelectorsSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 902 +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} +#endif +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.NoFieldSelectorsSpec where + +import TemplateTestImports + +#if __GLASGOW_HASKELL__ >= 902 + +mkPersist sqlSettings {mpsFieldLabelModifier = const id} [persistLowerCase| +User + ident Text + name Text + Primary ident + team TeamId + type Text + +Team + name Text +|] + +spec :: Spec +spec = it "compiles" True + +#else + +spec :: Spec +spec = do + it "only works with GHC 9.2 or greater" $ do + pendingWith "only works with GHC 9.2 or greater" + +#endif diff --git a/test/Database/Persist/TH/OverloadedLabelSpec.hs b/test/Database/Persist/TH/OverloadedLabelSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/OverloadedLabelSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} + +module Database.Persist.TH.OverloadedLabelSpec where + +import TemplateTestImports + +mkPersist + sqlSettings + [persistUpperCase| + +User + name String + age Int + +Dog + userId UserId + name String + age Int + +Organization + name String + +Student + userId UserId + departmentName String + Primary userId +|] + +spec :: Spec +spec = describe "OverloadedLabels" $ do + it "works for monomorphic labels" $ do + let + UserName = #name + OrganizationName = #name + DogName = #name + + compiles + + it "works for polymorphic labels" $ do + let + name :: (_) => EntityField rec a + name = #name + + UserName = name + OrganizationName = name + DogName = name + + compiles + + it "works for id labels" $ do + let + UserId = #id + orgId = #id :: EntityField Organization OrganizationId + + compiles + + it "works for Primary labels" $ do + let + StudentId = #id + studentId = #id :: EntityField Student StudentId + + compiles + +compiles :: IO () +compiles = pure () diff --git a/test/Database/Persist/TH/PersistWith/Model.hs b/test/Database/Persist/TH/PersistWith/Model.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/PersistWith/Model.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.PersistWith.Model where + +import TemplateTestImports + +import Database.Persist.TH.PersistWith.Model2 as Model2 + +mkPersistWith + sqlSettings + $(discoverEntities) + [persistLowerCase| + +IceCream + flavor FlavorId + otherFlavor Model2.FlavorId + +|] diff --git a/test/Database/Persist/TH/PersistWith/Model2.hs b/test/Database/Persist/TH/PersistWith/Model2.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/PersistWith/Model2.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.PersistWith.Model2 where + +import TemplateTestImports + +mkPersist + sqlSettings + [persistLowerCase| + +Flavor + name Text + +|] diff --git a/test/Database/Persist/TH/PersistWithSpec.hs b/test/Database/Persist/TH/PersistWithSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/PersistWithSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.PersistWithSpec where + +import Control.Monad +import Database.Persist.TH.PersistWith.Model as Model (IceCream, IceCreamId) +import Language.Haskell.TH as TH +import TemplateTestImports + +mkPersistWith + sqlSettings + $(discoverEntities) + [persistLowerCase| + +BestTopping + iceCream IceCreamId + otherCream Model.IceCreamId + keyCream (Key IceCream) + qualifiedKeyCream (Key Model.IceCream) + nullableCream IceCreamId Maybe + maybeCream (Maybe IceCreamId) + maybeQualifiedCream (Maybe Model.IceCreamId) + maybeQualifiedKeyCream (Maybe (Key Model.IceCream)) + maybeKeyCream (Maybe (Key IceCream)) + +|] + +deriving instance Show (EntityField BestTopping a) +deriving instance Eq (EntityField BestTopping a) + +data SomeField where + SomeField :: EntityField BestTopping a -> SomeField + +allFields = + [ SomeField BestToppingIceCream + , SomeField BestToppingOtherCream + , SomeField BestToppingKeyCream + , SomeField BestToppingQualifiedKeyCream + , SomeField BestToppingMaybeCream + , SomeField BestToppingNullableCream + , SomeField BestToppingMaybeQualifiedCream + , SomeField BestToppingMaybeQualifiedKeyCream + , SomeField BestToppingMaybeKeyCream + ] + +spec :: Spec +spec = describe "mkPersistWith" $ do + describe "finds references" $ do + forM_ allFields $ \(SomeField field) -> + it (show field) (shouldReferToIceCream field) + +shouldReferToIceCream :: EntityField BestTopping a -> IO () +shouldReferToIceCream field = + unless (reference == iceCreamRef) $ do + expectationFailure $ + mconcat + [ "The field '" + , show field + , "' does not have a reference to IceCream.\n" + , "Got Reference: " + , show reference + , "\n" + , "Expected : " + , show iceCreamRef + ] + where + reference = + fieldReference (persistFieldDef field) + iceCreamRef = + ForeignRef (EntityNameHS "IceCream") diff --git a/test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs b/test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.RequireOnlyPersistImportSpec where + +-- This test asserts this is the only import required to define entities +-- See: https://github.com/yesodweb/persistent/pull/1369 +import Database.Persist.TH + +-- always explicitly import qualified Hspec in the context of this spec +import qualified Test.Hspec as HS + +mkPersist + sqlSettings + [persistLowerCase| +Plain + name String + age Int + deriving Show Eq + +JsonEncoded json + name String + age Int + deriving Show Eq +|] + +spec :: HS.Spec +spec = + HS.describe "RequireOnlyPersistImport" $ do + HS.it "Plain" $ do + let + typeSigPlain :: String -> Int -> Plain + typeSigPlain = Plain + compiles + + HS.it "JsonEncoded" $ do + let + typeSigJsonEncoded :: String -> Int -> JsonEncoded + typeSigJsonEncoded = JsonEncoded + compiles + +compiles :: HS.Expectation +compiles = True `HS.shouldBe` True diff --git a/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs b/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.SharedPrimaryKeyImportedSpec where + +import TemplateTestImports + +import Control.Monad.IO.Class +import Data.Proxy +import Database.Persist +import Database.Persist.Sql +import Database.Persist.Sql.Util +import Database.Persist.TH +import Language.Haskell.TH +import Test.Hspec + +import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) + +mkPersistWith + sqlSettings + $(discoverEntities) + [persistLowerCase| + +ProfileX + Id UserId + email String + +|] + +-- This test is very similar to the one in SharedPrimaryKeyTest, but it is +-- able to use 'UserId' directly, since the type is imported from another +-- module. +spec :: Spec +spec = describe "Shared Primary Keys Imported" $ do + describe "PersistFieldSql" $ do + it "should match underlying key" $ do + sqlType (Proxy @UserId) + `shouldBe` sqlType (Proxy @ProfileXId) + + describe "getEntityId FieldDef" $ do + it "should match underlying primary key" $ do + let + getSqlType :: (PersistEntity a) => Proxy a -> SqlType + getSqlType p = + case getEntityId (entityDef p) of + EntityIdField fd -> + fieldSqlType fd + _ -> + SqlOther "Composite Key" + getSqlType (Proxy @User) + `shouldBe` getSqlType (Proxy @ProfileX) + + describe "foreign reference should work" $ do + it "should have a foreign reference" $ do + pendingWith "issue #1289" + let + Just fd = + getEntityIdField (entityDef (Proxy @ProfileX)) + fieldReference fd + `shouldBe` ForeignRef (EntityNameHS "User") diff --git a/test/Database/Persist/TH/SharedPrimaryKeySpec.hs b/test/Database/Persist/TH/SharedPrimaryKeySpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/SharedPrimaryKeySpec.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.SharedPrimaryKeySpec where + +import TemplateTestImports + +import Data.Proxy +import Data.Time +import Database.Persist +import Database.Persist.EntityDef +import Database.Persist.Sql +import Database.Persist.Sql.Util +import Database.Persist.TH +import Test.Hspec + +share + [mkPersist sqlSettings] + [persistLowerCase| + +User + name String + +Profile + Id UserId + email String + +Profile2 + Id (Key User) + email String + +DayKeyTable + Id Day + name Text + +RefDayKey + dayKey DayKeyTableId + +|] + +spec :: Spec +spec = describe "Shared Primary Keys" $ do + let + getSqlType :: (PersistEntity a) => Proxy a -> SqlType + getSqlType p = + case getEntityId (entityDef p) of + EntityIdField fd -> + fieldSqlType fd + _ -> + SqlOther "Composite Key" + + keyProxy :: Proxy a -> Proxy (Key a) + keyProxy _ = Proxy + + sqlTypeEquivalent + :: (PersistFieldSql (Key a), PersistEntity a) + => Proxy a + -> Expectation + sqlTypeEquivalent proxy = + sqlType (keyProxy proxy) `shouldBe` getSqlType proxy + + testSqlTypeEquivalent + :: (PersistFieldSql (Key a), PersistEntity a) + => Proxy a + -> Spec + testSqlTypeEquivalent prxy = + it "has equivalent SqlType from sqlType and entityId" $ + sqlTypeEquivalent prxy + describe "PersistFieldSql" $ do + it "should match underlying key" $ do + sqlType (Proxy @UserId) + `shouldBe` sqlType (Proxy @ProfileId) + + describe "User" $ do + it "has default ID key, SqlInt64" $ do + sqlType (Proxy @UserId) + `shouldBe` SqlInt64 + + testSqlTypeEquivalent (Proxy @User) + + describe "Profile" $ do + it "has same ID key type as User" $ do + sqlType (Proxy @ProfileId) + `shouldBe` sqlType (Proxy @UserId) + testSqlTypeEquivalent (Proxy @Profile) + + describe "Profile2" $ do + it "has same ID key type as User" $ do + sqlType (Proxy @Profile2Id) + `shouldBe` sqlType (Proxy @UserId) + testSqlTypeEquivalent (Proxy @Profile2) + + describe "getEntityId FieldDef" $ do + it "should match underlying primary key" $ do + getSqlType (Proxy @User) + `shouldBe` getSqlType (Proxy @Profile) + + describe "DayKeyTable" $ do + testSqlTypeEquivalent (Proxy @DayKeyTable) + + it "sqlType has Day type" $ do + sqlType (Proxy @Day) + `shouldBe` sqlType (Proxy @DayKeyTableId) + + it "getSqlType has Day type" $ do + sqlType (Proxy @Day) + `shouldBe` getSqlType (Proxy @DayKeyTable) + + describe "RefDayKey" $ do + let + [dayKeyField] = + getEntityFields (entityDef (Proxy @RefDayKey)) + testSqlTypeEquivalent (Proxy @RefDayKey) + + it "has same sqltype as underlying" $ do + fieldSqlType dayKeyField + `shouldBe` sqlType (Proxy @Day) + + it "has the right fieldType" $ do + fieldType dayKeyField + `shouldBe` FTTypeCon Nothing "DayKeyTableId" + + it "has the right type" $ do + let + _ = + refDayKeyDayKey + :: RefDayKey -> DayKeyTableId + _ = + RefDayKeyDayKey + :: EntityField RefDayKey DayKeyTableId + True `shouldBe` True + + it "has a foreign ref" $ do + case fieldReference dayKeyField of + ForeignRef refName -> do + refName `shouldBe` EntityNameHS "DayKeyTable" + other -> + fail $ "expected foreign ref, got: " <> show other diff --git a/test/Database/Persist/TH/SumSpec.hs b/test/Database/Persist/TH/SumSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/SumSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.SumSpec where + +import TemplateTestImports + +import Database.Persist.TH.MultiBlockSpec.Model + +share + [ mkPersistWith sqlSettings importDefList + ] + [persistLowerCase| + +What + name Text + +Lamp + name Text + ++Please + what WhatId + lamp LampId +|] + +spec :: Spec +spec = do + it "should warn" True diff --git a/test/Database/Persist/TH/ToFromPersistValuesSpec.hs b/test/Database/Persist/TH/ToFromPersistValuesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/ToFromPersistValuesSpec.hs @@ -0,0 +1,271 @@ +{-# 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 #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.TH.ToFromPersistValuesSpec where + +import TemplateTestImports + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NEL +import Database.Persist.Class.PersistEntity +import Database.Persist.Sql.Util + +instance (PersistFieldSql a) => PersistFieldSql (NonEmpty a) where + sqlType _ = SqlString + +instance (PersistField a) => PersistField (NonEmpty a) where + toPersistValue = toPersistValue . NEL.toList + fromPersistValue pv = do + xs <- fromPersistValue pv + case xs of + [] -> Left "PersistField: NonEmpty found unexpected Empty List" + (l : ls) -> Right (l :| ls) + +mkPersist + sqlSettings + [persistLowerCase| + +NormalModel + name Text + age Int + deriving Eq Show + +PrimaryModel + name Text + age Int + Primary name age + deriving Eq Show + +IsMigrationOnly + name Text + age Int + blargh Int MigrationOnly + deriving Eq Show + +HasListField + names [Text] + deriving Eq Show + +HasNonEmptyListField + names (NonEmpty Text) + deriving Eq Show + +HasNonEmptyListKeyField + names (NonEmpty (Key NormalModel)) + deriving Eq Show +|] + +spec :: Spec +spec = describe "{to,from}PersistValues" $ do + let + toPersistValues + :: (PersistEntity rec) => rec -> [PersistValue] + toPersistValues = + map toPersistValue . toPersistFields + + subject + :: (PersistEntity rec, Show rec, Eq rec) + => rec + -> [PersistValue] + -> Spec + subject model fields = do + it "toPersistValues" $ do + toPersistValues model + `shouldBe` fields + it "fromPersistValues" $ do + fromPersistValues fields + `shouldBe` Right model + describe "NormalModel" $ do + subject + (NormalModel "hello" 30) + [ PersistText "hello" + , PersistInt64 30 + ] + + describe "PrimaryModel" $ do + subject + (PrimaryModel "hello" 30) + [ PersistText "hello" + , PersistInt64 30 + ] + + describe "IsMigrationOnly" $ do + subject + (IsMigrationOnly "hello" 30) + [ PersistText "hello" + , PersistInt64 30 + ] + + describe "mkInsertValues" $ do + describe "NormalModel" $ do + it "has all values" $ do + mkInsertValues (NormalModel "hello" 30) + `shouldBe` [ PersistText "hello" + , PersistInt64 30 + ] + describe "PrimaryModel" $ do + it "has all values" $ do + mkInsertValues (PrimaryModel "hello" 30) + `shouldBe` [ PersistText "hello" + , PersistInt64 30 + ] + describe "IsMigrationOnly" $ do + it "has all values" $ do + mkInsertValues (IsMigrationOnly "hello" 30) + `shouldBe` [ PersistText "hello" + , PersistInt64 30 + ] + describe "parseEntityValues" $ do + let + subject + :: forall rec + . (PersistEntity rec, Show rec, Eq rec) + => [PersistValue] + -> Entity rec + -> Spec + subject pvs rec = + it "parses" $ do + parseEntityValues (entityDef (Proxy @rec)) pvs + `shouldBe` Right rec + describe "NormalModel" $ do + subject + [ PersistInt64 20 + , PersistText "hello" + , PersistInt64 30 + ] + Entity + { entityKey = + NormalModelKey 20 + , entityVal = + NormalModel "hello" 30 + } + describe "PrimaryModel" $ do + subject + [ PersistText "hey" + , PersistInt64 30 + ] + Entity + { entityKey = + PrimaryModelKey "hey" 30 + , entityVal = + PrimaryModel "hey" 30 + } + describe "IsMigrationOnly" $ do + subject + [ PersistInt64 20 + , PersistText "hello" + , PersistInt64 30 + ] + Entity + { entityKey = + IsMigrationOnlyKey 20 + , entityVal = + IsMigrationOnly "hello" 30 + } + describe "entityValues" $ do + let + subject + :: forall rec + . (PersistEntity rec, Show rec, Eq rec) + => [PersistValue] + -> Entity rec + -> Spec + subject pvals entity = do + it "renders as you would expect" $ do + entityValues entity + `shouldBe` pvals + it "round trips with parseEntityValues" $ do + parseEntityValues + (entityDef $ Proxy @rec) + (entityValues entity) + `shouldBe` Right entity + describe "NormalModel" $ do + subject + [ PersistInt64 10 + , PersistText "hello" + , PersistInt64 20 + ] + Entity + { entityKey = + NormalModelKey 10 + , entityVal = + NormalModel "hello" 20 + } + describe "PrimaryModel" $ do + subject + [ PersistText "hello" + , PersistInt64 20 + ] + Entity + { entityKey = + PrimaryModelKey "hello" 20 + , entityVal = + PrimaryModel "hello" 20 + } + describe "IsMigrationOnly" $ do + subject + [ PersistInt64 20 + , PersistText "hello" + , PersistInt64 20 + ] + Entity + { entityKey = + IsMigrationOnlyKey 20 + , entityVal = + IsMigrationOnly "hello" 20 + } + + describe "HasListField" $ do + subject + [ PersistInt64 10 + , PersistList [PersistText "hello"] + ] + Entity + { entityKey = + HasListFieldKey 10 + , entityVal = + HasListField ["hello"] + } + describe "HasNonEmptyListField" $ do + subject + [ PersistInt64 10 + , PersistList [PersistText "hello"] + ] + Entity + { entityKey = + HasNonEmptyListFieldKey 10 + , entityVal = + HasNonEmptyListField (pure "hello") + } + describe "HasNonEmptyListKeyField" $ do + subject + [ PersistInt64 5 + , PersistList [PersistInt64 4] + ] + Entity + { entityKey = + HasNonEmptyListKeyFieldKey 5 + , entityVal = + HasNonEmptyListKeyField (pure (NormalModelKey 4)) + } diff --git a/test/Database/Persist/TH/TypeLitFieldDefsSpec.hs b/test/Database/Persist/TH/TypeLitFieldDefsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/TH/TypeLitFieldDefsSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + +module Database.Persist.TH.TypeLitFieldDefsSpec where + +import GHC.TypeLits +import TemplateTestImports + +newtype Finite (n :: Nat) = Finite Int + +instance PersistField (Finite n) where + toPersistValue (Finite n) = toPersistValue n + fromPersistValue = fmap Finite . fromPersistValue + +instance PersistFieldSql (Finite n) where + sqlType _ = sqlType (Proxy :: Proxy Int) + +newtype Labelled (t :: Symbol) = Labelled Int + +instance PersistField (Labelled n) where + toPersistValue (Labelled n) = toPersistValue n + fromPersistValue = fmap Labelled . fromPersistValue + +instance PersistFieldSql (Labelled n) where + sqlType _ = sqlType (Proxy :: Proxy Int) + +mkPersist + sqlSettings + [persistLowerCase| +WithFinite + one (Finite 1) + twenty (Finite 20) + +WithLabelled + one (Labelled "one") + twenty (Labelled "twenty") +|] + +spec :: Spec +spec = describe "TypeLitFieldDefs" $ do + it "should support numeric type literal fields in entity definition" $ do + let + mkFinite :: Finite 1 -> Finite 20 -> WithFinite + mkFinite = WithFinite + compiles + + it "should support string based type literal fields in entity definition" $ do + let + mkLabelled :: Labelled "one" -> Labelled "twenty" -> WithLabelled + mkLabelled = WithLabelled + compiles + +compiles :: Expectation +compiles = True `shouldBe` True diff --git a/test/Database/Persist/THSpec.hs b/test/Database/Persist/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Database/Persist/THSpec.hs @@ -0,0 +1,569 @@ +{-# 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 #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.THSpec where + +import Control.Applicative (Const (..)) +import Data.Aeson (decode, encode) +import Data.ByteString.Lazy.Char8 () +import Data.Coerce +import Data.Functor.Identity (Identity (..)) +import Data.Int +import qualified Data.List as List +import Data.Proxy +import Data.Text (Text, pack) +import Data.Time +import GHC.Generics (Generic) +import qualified Language.Haskell.TH.Syntax as TH +import System.Environment +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen (Gen) + +import Database.Persist +import Database.Persist.EntityDef.Internal +import Database.Persist.Quasi.Internal (SourceLoc (..), sourceLocFromTHLoc) +import Database.Persist.Sql +import Database.Persist.Sql.Util +import Database.Persist.TH +import Database.Persist.Types.SourceSpan +import TemplateTestImports + +import qualified Database.Persist.TH.CommentSpec as CommentSpec +import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec +import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec +import qualified Database.Persist.TH.EmbedSpec as EmbedSpec +import qualified Database.Persist.TH.EntityHaddockSpec as EntityHaddockSpec +import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec +import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec +import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec +import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec +import qualified Database.Persist.TH.MaybeFieldDefsSpec as MaybeFieldDefsSpec +import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec +import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec +import qualified Database.Persist.TH.NestedSymbolsInTypeSpec as NestedSymbolsInTypeSpec +import qualified Database.Persist.TH.NoFieldSelectorsSpec as NoFieldSelectorsSpec +import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec +import qualified Database.Persist.TH.PersistWithSpec as PersistWithSpec +import qualified Database.Persist.TH.RequireOnlyPersistImportSpec as RequireOnlyPersistImportSpec +import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec +import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec +import qualified Database.Persist.TH.SumSpec as SumSpec +import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec +import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpec + +-- test to ensure we can have types ending in Id that don't trash the TH +-- machinery +type TextId = Text + +-- | Location above the block defining Person below. Must be before it. Do not move! +-- Used to test TH definition positions are plausible. +personDefBeforeLoc :: SourceLoc +personDefBeforeLoc = $(TH.lift . sourceLocFromTHLoc =<< TH.location) + +share + [ mkPersistWith + sqlSettings{mpsGeneric = False, mpsDeriveInstances = [''Generic]} + [entityDef @JsonEncodingSpec.JsonEncoding Proxy] + ] + [persistUpperCase| + +Person json + name Text + age Int Maybe + foo Foo + address Address + deriving Show Eq + +HasSimpleCascadeRef + person PersonId OnDeleteCascade + deriving Show Eq + +Address json + street Text + city Text + zip Int Maybe + deriving Show Eq +NoJson + foo Text + deriving Show Eq + +CustomIdName + Id sql=id_col + name Text + deriving Show Eq + +QualifiedReference + jsonEncoding JsonEncodingSpec.JsonEncodingId + +|] + +-- | Location after the block defining Person above. Must be after it. Do not move! +-- Used to test TH definition positions are plausible. +personDefAfterLoc :: SourceLoc +personDefAfterLoc = $(TH.lift . sourceLocFromTHLoc =<< TH.location) + +mkPersist + sqlSettings + [persistLowerCase| +HasPrimaryDef + userId Int + name String + Primary userId + +HasMultipleColPrimaryDef + foobar Int + barbaz String + Primary foobar barbaz + +TestDefaultKeyCol + Id TestDefaultKeyColId + name String + +HasIdDef + Id Int + name String + +HasDefaultId + name String + +HasCustomSqlId + Id String sql=my_id + name String + +SharedPrimaryKey + Id HasDefaultIdId + name String + +SharedPrimaryKeyWithCascade + Id (Key HasDefaultId) OnDeleteCascade + name String + +SharedPrimaryKeyWithCascadeAndCustomName + Id (Key HasDefaultId) OnDeleteCascade sql=my_id + name String + +Top + name Text + +Middle + top TopId + Primary top + +Bottom + middle MiddleId + Primary middle + +-- Test that a field can be named Key +KeyTable + key Text + +|] + +share + [mkPersist sqlSettings{mpsGeneric = False, mpsGenerateLenses = True}] + [persistLowerCase| +Lperson json + name Text + age Int Maybe + address Laddress + deriving Show Eq +Laddress json + street Text + city Text + zip Int Maybe + deriving Show Eq +CustomPrimaryKey + anInt Int + Primary anInt +|] + +arbitraryT :: Gen Text +arbitraryT = pack <$> arbitrary + +instance Arbitrary Person where + arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Address where + arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary + +spec :: Spec +spec = describe "THSpec" $ do + describe "SumSpec" $ SumSpec.spec + PersistWithSpec.spec + KindEntitiesSpec.spec + NestedSymbolsInTypeSpec.spec + OverloadedLabelSpec.spec + SharedPrimaryKeySpec.spec + SharedPrimaryKeyImportedSpec.spec + ImplicitIdColSpec.spec + MaybeFieldDefsSpec.spec + TypeLitFieldDefsSpec.spec + MigrationOnlySpec.spec + NoFieldSelectorsSpec.spec + EmbedSpec.spec + DiscoverEntitiesSpec.spec + MultiBlockSpec.spec + ForeignRefSpec.spec + ToFromPersistValuesSpec.spec + JsonEncodingSpec.spec + CommentSpec.spec + EntityHaddockSpec.spec + CompositeKeyStyleSpec.spec + it "QualifiedReference" $ do + let + ed = entityDef @QualifiedReference Proxy + [FieldDef{..}] = entityFields ed + fieldType `shouldBe` FTTypeCon (Just "JsonEncodingSpec") "JsonEncodingId" + fieldSqlType `shouldBe` sqlType @JsonEncodingSpec.JsonEncodingId Proxy + fieldReference `shouldBe` ForeignRef (EntityNameHS "JsonEncoding") + + describe "TestDefaultKeyCol" $ do + let + EntityIdField FieldDef{..} = + entityId (entityDef (Proxy @TestDefaultKeyCol)) + it "should be a BackendKey SqlBackend" $ do + -- the purpose of this test is to verify that a custom Id column of + -- the form: + -- > ModelName + -- > Id ModelNameId + -- + -- should behave like an implicit id column. + (TestDefaultKeyColKey (SqlBackendKey 32) :: Key TestDefaultKeyCol) + `shouldBe` (toSqlKey 32 :: Key TestDefaultKeyCol) + describe "HasDefaultId" $ do + let + EntityIdField FieldDef{..} = + entityId (entityDef (Proxy @HasDefaultId)) + it "should have usual db name" $ do + fieldDB `shouldBe` FieldNameDB "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` FieldNameHS "Id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "persistfieldsql should be right" $ do + sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId" + + describe "HasCustomSqlId" $ do + let + EntityIdField FieldDef{..} = + entityId (entityDef (Proxy @HasCustomSqlId)) + it "should have custom db name" $ do + fieldDB `shouldBe` FieldNameDB "my_id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` FieldNameHS "Id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlString + it "should have correct haskell type" $ do + fieldType `shouldBe` FTTypeCon Nothing "String" + describe "HasIdDef" $ do + let + EntityIdField FieldDef{..} = + entityId (entityDef (Proxy @HasIdDef)) + it "should have usual db name" $ do + fieldDB `shouldBe` FieldNameDB "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` FieldNameHS "Id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType `shouldBe` FTTypeCon Nothing "Int" + + describe "SharedPrimaryKey" $ do + let + sharedDef = entityDef (Proxy @SharedPrimaryKey) + EntityIdField FieldDef{..} = + entityId sharedDef + it "should have usual db name" $ do + fieldDB `shouldBe` FieldNameDB "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` FieldNameHS "Id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "should have correct underlying (as reported by sqltype)" $ do + fieldSqlType `shouldBe` sqlType (Proxy :: Proxy HasDefaultIdId) + it "should have correct haskell type" $ do + fieldType `shouldBe` (FTTypeCon Nothing "HasDefaultIdId") + it "should have correct sql type from PersistFieldSql" $ do + sqlType (Proxy @SharedPrimaryKeyId) + `shouldBe` SqlInt64 + it "should have same sqlType as underlying record" $ do + sqlType (Proxy @SharedPrimaryKeyId) + `shouldBe` sqlType (Proxy @HasDefaultIdId) + it "should be a coercible newtype" $ do + coerce @Int64 3 + `shouldBe` SharedPrimaryKeyKey (toSqlKey 3) + + describe "SharedPrimaryKeyWithCascade" $ do + let + EntityIdField FieldDef{..} = + entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade)) + it "should have usual db name" $ do + fieldDB `shouldBe` FieldNameDB "id" + it "should have usual haskell name" $ do + fieldHaskell `shouldBe` FieldNameHS "Id" + it "should have correct underlying sql type" $ do + fieldSqlType `shouldBe` SqlInt64 + it "should have correct haskell type" $ do + fieldType + `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") + it "should have cascade in field def" $ do + fieldCascade `shouldBe` noCascade{fcOnDelete = Just Cascade} + + describe "OnCascadeDelete" $ do + let + subject :: FieldDef + Just subject = + List.find ((FieldNameHS "person" ==) . fieldHaskell) $ + entityFields $ + simpleCascadeDef + simpleCascadeDef = + entityDef (Proxy :: Proxy HasSimpleCascadeRef) + expected = + FieldCascade + { fcOnDelete = Just Cascade + , fcOnUpdate = Nothing + } + describe "entityDef" $ do + it "correct position" $ do + let + Just theSpan = entitySpan simpleCascadeDef + theSpan `shouldSatisfy` ((> locStartLine personDefBeforeLoc) . spanStartLine) + theSpan `shouldSatisfy` (\s -> spanStartLine s < spanEndLine s) + theSpan `shouldSatisfy` ((< locStartLine personDefAfterLoc) . spanEndLine) + it "works" $ do + simpleCascadeDef + `shouldBe` EntityDef + { entityHaskell = EntityNameHS "HasSimpleCascadeRef" + , entityDB = EntityNameDB "HasSimpleCascadeRef" + , entityId = + EntityIdField + FieldDef + { fieldHaskell = FieldNameHS "Id" + , fieldDB = FieldNameDB "id" + , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId" + , fieldSqlType = SqlInt64 + , fieldReference = + NoReference + , fieldAttrs = [] + , fieldStrict = True + , fieldComments = Nothing + , fieldCascade = noCascade + , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True + } + , entityAttrs = [] + , entityFields = + [ FieldDef + { fieldHaskell = FieldNameHS "person" + , fieldDB = FieldNameDB "person" + , fieldType = FTTypeCon Nothing "PersonId" + , fieldSqlType = SqlInt64 + , fieldAttrs = [] + , fieldStrict = True + , fieldReference = + ForeignRef + (EntityNameHS "Person") + , fieldCascade = + FieldCascade{fcOnUpdate = Nothing, fcOnDelete = Just Cascade} + , fieldComments = Nothing + , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = False + } + ] + , entityUniques = [] + , entityForeigns = [] + , entityDerives = ["Show", "Eq"] + , entityExtra = mempty + , entitySum = False + , entityComments = Nothing + , -- We cannot test this is a precise value without + -- being really fragile, but we have another test to + -- verify the line is in range. + entitySpan = entitySpan simpleCascadeDef + } + it "has the cascade on the field def" $ do + fieldCascade subject `shouldBe` expected + it "doesn't have any extras" $ do + entityExtra simpleCascadeDef + `shouldBe` mempty + + describe "hasNaturalKey" $ do + let + subject :: (PersistEntity a) => Proxy a -> Bool + subject p = hasNaturalKey (entityDef p) + it "is True for Primary keyword" $ do + subject (Proxy @HasPrimaryDef) + `shouldBe` True + it "is True for multiple Primary columns " $ do + subject (Proxy @HasMultipleColPrimaryDef) + `shouldBe` True + it "is False for Id keyword" $ do + subject (Proxy @HasIdDef) + `shouldBe` False + it "is False for unspecified/default id" $ do + subject (Proxy @HasDefaultId) + `shouldBe` False + describe "hasCompositePrimaryKey" $ do + let + subject :: (PersistEntity a) => Proxy a -> Bool + subject p = hasCompositePrimaryKey (entityDef p) + it "is False for Primary with single column" $ do + subject (Proxy @HasPrimaryDef) + `shouldBe` False + it "is True for multiple Primary columns " $ do + subject (Proxy @HasMultipleColPrimaryDef) + `shouldBe` True + it "is False for Id keyword" $ do + subject (Proxy @HasIdDef) + `shouldBe` False + it "is False for unspecified/default id" $ do + subject (Proxy @HasDefaultId) + `shouldBe` False + + describe "JSON serialization" $ do + prop "to/from is idempotent" $ \person -> + decode (encode person) == Just (person :: Person) + it "decode" $ + decode + "{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" + `shouldBe` Just + (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing) + describe "JSON serialization for Entity" $ do + let + key = PersonKey 0 + prop "to/from is idempotent" $ \person -> + decode (encode (Entity key person)) == Just (Entity key (person :: Person)) + it "decode" $ + decode + "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" + `shouldBe` Just + (Entity key (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing)) + it "lens operations" $ do + let + street1 = "street1" + city1 = "city1" + city2 = "city2" + zip1 = Just 12345 + address1 = Laddress street1 city1 zip1 + address2 = Laddress street1 city2 zip1 + name1 = "name1" + age1 = Just 27 + person1 = Lperson name1 age1 address1 + person2 = Lperson name1 age1 address2 + (person1 ^. lpersonAddress) `shouldBe` address1 + (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1 + (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2 + describe "Derived Show/Read instances" $ do + -- This tests confirms https://github.com/yesodweb/persistent/issues/1104 remains fixed + it + "includes the name of the newtype when showing/reading a Key, i.e. uses the stock strategy when deriving Show/Read" + $ do + show (PersonKey 0) + `shouldBe` "PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 0}}" + read (show (PersonKey 0)) `shouldBe` PersonKey 0 + + show (CustomPrimaryKeyKey 0) + `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}" + read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0 + + describe "tabulateEntityA" $ do + it "works" $ do + person <- + tabulateEntityA $ \case + PersonName -> + pure "Matt" + PersonAge -> do + (year, _, _) <- toGregorian . utctDay <$> getCurrentTime + pure $ Just (fromInteger year - 1988) + PersonFoo -> do + _ <- lookupEnv "PERSON_FOO" :: IO (Maybe String) + pure Bar + PersonAddress -> + pure $ Address "lol no" "Denver" Nothing + PersonId -> + pure $ toSqlKey 123 + expectedAge <- + fromInteger . subtract 1988 . (\(a, _, _) -> a) . toGregorian . utctDay + <$> getCurrentTime + person + `shouldBe` Entity + (toSqlKey 123) + Person + { personName = + "Matt" + , personAge = + Just expectedAge + , personFoo = + Bar + , personAddress = + Address "lol no" "Denver" Nothing + } + + describe "tabulateEntity" $ do + it "works" $ do + let + addressTabulate = + tabulateEntity $ \case + AddressId -> + toSqlKey 123 + AddressStreet -> + "nope" + AddressCity -> + "Denver" + AddressZip -> + Nothing + addressTabulate + `shouldBe` Entity + (toSqlKey 123) + Address + { addressStreet = "nope" + , addressCity = "Denver" + , addressZip = Nothing + } + + describe "CustomIdName" $ do + it "has a good safe to insert class instance" $ do + let + proxy = Proxy :: (SafeToInsert CustomIdName) => Proxy CustomIdName + proxy `shouldBe` Proxy + +(&) :: a -> (a -> b) -> b +x & f = f x + +(^.) + :: s + -> ((a -> Const a b) -> (s -> Const a t)) + -> a +x ^. lens = getConst $ lens Const x + +(.~) + :: ((a -> Identity b) -> (s -> Identity t)) + -> b + -> s + -> t +lens .~ val = runIdentity . lens (\_ -> Identity val) diff --git a/test/TemplateTestImports.hs b/test/TemplateTestImports.hs new file mode 100644 --- /dev/null +++ b/test/TemplateTestImports.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module TemplateTestImports + ( module TemplateTestImports + , module X + ) where + +import Data.Aeson.TH +import Test.QuickCheck + +import Control.Monad +import Data.Int as X +import Data.Maybe +import Data.Proxy as X +import Data.Text as X (Text) +import Database.Persist.Sql as X +import Database.Persist.TH as X +import Language.Haskell.TH.Syntax +import Test.Hspec as X + +data Foo = Bar | Baz + deriving (Show, Eq) + +deriveJSON defaultOptions ''Foo + +derivePersistFieldJSON "Foo" + +instance Arbitrary Foo where + arbitrary = elements [Bar, Baz] diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,509 +1,17 @@ -{-# language RecordWildCards #-} +module Main where import Test.Hspec -import qualified Data.Text as T -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as Map -import Data.Time -import Database.Persist.Class.PersistField -import Database.Persist.Quasi -import Database.Persist.Types +import qualified Database.Persist.ClassSpec as ClassSpec +import qualified Database.Persist.PersistValueSpec as PersistValueSpec +import qualified Database.Persist.QuasiSpec as QuasiSpec +import qualified Database.Persist.THSpec as THSpec main :: IO () main = hspec $ do - describe "tokenization" $ do - it "handles normal words" $ - tokenize " foo bar baz" `shouldBe` - [ Spaces 1 - , Token "foo" - , Spaces 3 - , Token "bar" - , Spaces 2 - , Token "baz" - ] - it "handles quotes" $ - tokenize " \"foo bar\" \"baz\"" `shouldBe` - [ Spaces 2 - , Token "foo bar" - , Spaces 2 - , Token "baz" - ] - it "handles quotes mid-token" $ - tokenize " x=\"foo bar\" \"baz\"" `shouldBe` - [ Spaces 2 - , Token "x=foo bar" - , Spaces 2 - , Token "baz" - ] - it "handles escaped quote mid-token" $ - tokenize " x=\\\"foo bar\" \"baz\"" `shouldBe` - [ Spaces 2 - , Token "x=\\\"foo" - , Spaces 1 - , Token "bar\"" - , Spaces 2 - , Token "baz" - ] - it "handles unnested parantheses" $ - tokenize " (foo bar) (baz)" `shouldBe` - [ Spaces 2 - , Token "foo bar" - , Spaces 2 - , Token "baz" - ] - it "handles unnested parantheses mid-token" $ - tokenize " x=(foo bar) (baz)" `shouldBe` - [ Spaces 2 - , Token "x=foo bar" - , Spaces 2 - , Token "baz" - ] - it "handles nested parantheses" $ - tokenize " (foo (bar)) (baz)" `shouldBe` - [ Spaces 2 - , Token "foo (bar)" - , Spaces 2 - , Token "baz" - ] - it "escaping" $ - tokenize " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` - [ Spaces 2 - , Token "foo (bar" - , Spaces 2 - , Token "y=baz\"" - ] - it "mid-token quote in later token" $ - tokenize "foo bar baz=(bin\")" `shouldBe` - [ Token "foo" - , Spaces 1 - , Token "bar" - , Spaces 1 - , Token "baz=bin\"" - ] - describe "comments" $ do - it "recognizes one line" $ do - tokenize "-- | this is a comment" `shouldBe` - [ DocComment "-- | this is a comment" - ] - it "map tokenize" $ do - map tokenize ["Foo", "-- | Hello"] - `shouldBe` - [ [Token "Foo"] - , [DocComment "-- | Hello"] - ] - it "works if comment is indented" $ do - tokenize " -- | comment" `shouldBe` - [ Spaces 2, DocComment "-- | comment" - ] - describe "parseFieldType" $ do - it "simple types" $ - parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") - it "module types" $ - parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar") - it "application" $ - parseFieldType "Foo Bar" `shouldBe` Right ( - FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") - it "application multiple" $ - parseFieldType "Foo Bar Baz" `shouldBe` Right ( - (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") - `FTApp` FTTypeCon Nothing "Baz" - ) - it "parens" $ do - let foo = FTTypeCon Nothing "Foo" - bar = FTTypeCon Nothing "Bar" - baz = FTTypeCon Nothing "Baz" - parseFieldType "Foo (Bar Baz)" `shouldBe` Right ( - foo `FTApp` (bar `FTApp` baz)) - it "lists" $ do - let foo = FTTypeCon Nothing "Foo" - bar = FTTypeCon Nothing "Bar" - bars = FTList bar - baz = FTTypeCon Nothing "Baz" - parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( - foo `FTApp` bars `FTApp` baz) - - describe "preparse" $ do - it "recognizes entity" $ do - preparse "Person\n name String\n age Int" `shouldBe` - [ Line { lineIndent = 0, tokens = ["Person"] } - , Line { lineIndent = 2, tokens = ["name", "String"] } - , Line { lineIndent = 2, tokens = ["age", "Int"] } - ] - describe "recognizes comments" $ do - let text = "Foo\n x X\n-- | Hello\nBar\n name String" - linesText = T.lines text - it "T.lines" $ do - linesText - `shouldBe` - [ "Foo" - , " x X" - , "-- | Hello" - , "Bar" - , " name String" - ] - let tokens = map tokenize linesText - it "map tokenize" $ do - tokens `shouldBe` - [ [ Token "Foo" ] - , [ Spaces 2, Token "x", Spaces 1, Token "X"] - , [ DocComment "-- | Hello" ] - , [ Token "Bar" ] - , [ Spaces 1, Token "name", Spaces 1, Token "String" ] - ] - let filtered = filter (not . empty) tokens - it "filter (not . empty)" $ do - filtered `shouldBe` - [ [ Token "Foo" ] - , [ Spaces 2, Token "x", Spaces 1, Token "X"] - , [ DocComment "-- | Hello" ] - , [ Token "Bar" ] - , [ Spaces 1, Token "name", Spaces 1, Token "String" ] - ] - let spacesRemoved = removeSpaces filtered - it "removeSpaces" $ do - spacesRemoved `shouldBe` - [ Line { lineIndent = 0, tokens = ["Foo"] } - , Line { lineIndent = 2, tokens = ["x", "X"] } - , Line { lineIndent = 0, tokens = ["-- | Hello"] } - , Line { lineIndent = 0, tokens = ["Bar"] } - , Line { lineIndent = 1, tokens = ["name", "String"] } - ] - - it "preparse" $ do - preparse text `shouldBe` - [ Line { lineIndent = 0, tokens = ["Foo"] } - , Line { lineIndent = 2, tokens = ["x", "X"] } - , Line { lineIndent = 0, tokens = ["-- | Hello"] } - , Line { lineIndent = 0, tokens = ["Bar"] } - , Line { lineIndent = 1, tokens = ["name", "String"] } - ] - it "preparse indented" $ do - let t = T.unlines - [ " Foo" - , " x X" - , " -- | Comment" - , " -- hidden comment" - , " Bar" - , " name String" - ] - preparse t `shouldBe` - [ Line { lineIndent = 2, tokens = ["Foo"] } - , Line { lineIndent = 4, tokens = ["x", "X"] } - , Line { lineIndent = 2, tokens = ["-- | Comment"] } - , Line { lineIndent = 2, tokens = ["Bar"] } - , Line { lineIndent = 4, tokens = ["name", "String"] } - ] - it "preparse extra blocks" $ do - let t = T.unlines - [ "LowerCaseTable" - , " name String" - , " ExtraBlock" - , " foo bar" - , " baz" - , " ExtraBlock2" - , " something" - ] - preparse t `shouldBe` - [ Line { lineIndent = 0, tokens = ["LowerCaseTable"] } - , Line { lineIndent = 2, tokens = ["name", "String"] } - , Line { lineIndent = 2, tokens = ["ExtraBlock"] } - , Line { lineIndent = 4, tokens = ["foo", "bar"] } - , Line { lineIndent = 4, tokens = ["baz"] } - , Line { lineIndent = 2, tokens = ["ExtraBlock2"] } - , Line { lineIndent = 4, tokens = ["something"] } - ] - it "field comments" $ do - let text = T.unlines - [ "-- | Model" - , "Foo" - , " -- | Field" - , " name String" - ] - preparse text `shouldBe` - [ Line { lineIndent = 0, tokens = ["-- | Model"] } - , Line { lineIndent = 0, tokens = ["Foo"] } - , Line { lineIndent = 2, tokens = ["-- | Field"] } - , Line { lineIndent = 2, tokens = ["name", "String"] } - ] - - describe "empty" $ do - it "doesn't dispatch comments" $ do - [DocComment "-- | hello"] `shouldSatisfy` (not . empty) - it "removes spaces" $ do - [Spaces 3] `shouldSatisfy` empty - - describe "filter (not . empty)" $ do - let subject = filter (not . empty) - it "keeps comments" $ do - subject [[DocComment "-- | Hello"]] - `shouldBe` - [[DocComment "-- | Hello"]] - it "omits lines with only spaces" $ do - subject [[Spaces 3, Token "indented"], [Spaces 2]] - `shouldBe` - [[Spaces 3, Token "indented"]] - - describe "removeSpaces" $ do - it "sets indentation level for a line" $ do - removeSpaces [[Spaces 3, Token "hello", Spaces 1, Token "goodbye"]] - `shouldBe` - [ Line { lineIndent = 3, tokens = ["hello", "goodbye"] } - ] - it "does not remove comments" $ do - removeSpaces - [ [ DocComment "-- | asdf" ] - , [ Token "Foo" ] - , [ Spaces 2, Token "name", Spaces 1, Token "String" ] - ] - `shouldBe` - [ Line { lineIndent = 0, tokens = ["-- | asdf"] } - , Line { lineIndent = 0, tokens = ["Foo"] } - , Line { lineIndent = 2, tokens = ["name", "String"] } - ] - - describe "associateLines" $ do - let foo = Line { lineIndent = 0, tokens = pure "Foo" } - name'String = Line { lineIndent = 2, tokens = "name" :| ["String"] } - comment = Line { lineIndent = 0, tokens = pure "-- | comment" } - it "works" $ do - associateLines - [ comment - , foo - , name'String - ] - `shouldBe` - [ LinesWithComments - { lwcComments = ["comment"] - , lwcLines = foo :| [name'String] - } - ] - let bar = Line { lineIndent = 0, tokens = "Bar" :| ["sql", "=", "bars"] } - age'Int = Line { lineIndent = 1, tokens = "age" :| ["Int"] } - it "works when used consecutively" $ do - associateLines - [ bar - , age'Int - , comment - , foo - , name'String - ] - `shouldBe` - [ LinesWithComments - { lwcComments = [] - , lwcLines = bar :| [age'Int] - } - , LinesWithComments - { lwcComments = ["comment"] - , lwcLines = foo :| [name'String] - } - ] - it "works with textual input" $ do - let text = "Foo\n x X\n-- | Hello\nBar\n name String" - parsed = preparse text - allFull = skipEmpty parsed - associateLines allFull - `shouldBe` - [ LinesWithComments - { lwcLines = - Line {lineIndent = 0, tokens = "Foo" :| []} - :| [ Line {lineIndent = 2, tokens = "x" :| ["X"]} ] - , lwcComments = - [] - } - , LinesWithComments - { lwcLines = - Line {lineIndent = 0, tokens = "Bar" :| []} - :| [ Line {lineIndent = 1, tokens = "name" :| ["String"]}] - , lwcComments = - ["Hello"] - } - ] - it "works with extra blocks" $ do - let text = skipEmpty . preparse . T.unlines $ - [ "LowerCaseTable" - , " Id sql=my_id" - , " fullName Text" - , " ExtraBlock" - , " foo bar" - , " baz" - , " bin" - , " ExtraBlock2" - , " something" - ] - associateLines text `shouldBe` - [ LinesWithComments - { lwcLines = - Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :| - [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] } - , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] } - , Line { lineIndent = 4, tokens = pure "ExtraBlock" } - , Line { lineIndent = 8, tokens = "foo" :| ["bar"] } - , Line { lineIndent = 8, tokens = pure "baz" } - , Line { lineIndent = 8, tokens = pure "bin" } - , Line { lineIndent = 4, tokens = pure "ExtraBlock2" } - , Line { lineIndent = 8, tokens = pure "something" } - ] - , lwcComments = [] - } - ] - - it "works with extra blocks twice" $ do - let text = skipEmpty . preparse . T.unlines $ - [ "IdTable" - , " Id Day default=CURRENT_DATE" - , " name Text" - , "" - , "LowerCaseTable" - , " Id sql=my_id" - , " fullName Text" - , " ExtraBlock" - , " foo bar" - , " baz" - , " bin" - , " ExtraBlock2" - , " something" - ] - associateLines text `shouldBe` - [ LinesWithComments - { lwcLines = Line 0 (pure "IdTable") :| - [ Line 4 ("Id" :| ["Day", "default=CURRENT_DATE"]) - , Line 4 ("name" :| ["Text"]) - ] - , lwcComments = [] - } - , LinesWithComments - { lwcLines = - Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :| - [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] } - , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] } - , Line { lineIndent = 4, tokens = pure "ExtraBlock" } - , Line { lineIndent = 8, tokens = "foo" :| ["bar"] } - , Line { lineIndent = 8, tokens = pure "baz" } - , Line { lineIndent = 8, tokens = pure "bin" } - , Line { lineIndent = 4, tokens = pure "ExtraBlock2" } - , Line { lineIndent = 8, tokens = pure "something" } - ] - , lwcComments = [] - } - ] - - - it "works with field comments" $ do - let text = skipEmpty . preparse . T.unlines $ - [ "-- | Model" - , "Foo" - , " -- | Field" - , " name String" - ] - associateLines text `shouldBe` - [ LinesWithComments - { lwcLines = - Line { lineIndent = 0, tokens = "Foo" :| [] } :| - [ Line { lineIndent = 2, tokens = pure "-- | Field" } - , Line { lineIndent = 2, tokens = "name" :| ["String"] } - ] - , lwcComments = - ["Model"] - } - ] - - - - describe "parseLines" $ do - let lines = - T.unlines - [ "-- | Comment" - , "Foo" - , " -- | Field" - , " name String" - , " age Int" - , " Extra" - , " foo bar" - , " baz" - , " Extra2" - , " something" - ] - let [subject] = parse lowerCaseSettings lines - it "produces the right name" $ do - entityHaskell subject `shouldBe` HaskellName "Foo" - describe "entityFields" $ do - let fields = entityFields subject - it "has the right field names" $ do - map fieldHaskell fields `shouldMatchList` - [ HaskellName "name" - , HaskellName "age" - ] - it "has comments" $ do - map fieldComments fields `shouldBe` - [ Just "Field\n" - , Nothing - ] - it "has the comments" $ do - entityComments subject `shouldBe` - Just "Comment\n" - it "combines extrablocks" $ do - entityExtra subject `shouldBe` Map.fromList - [ ("Extra", [["foo", "bar"], ["baz"]]) - , ("Extra2", [["something"]]) - ] - describe "works with extra blocks" $ do - let [_, lowerCaseTable, idTable] = - parse lowerCaseSettings $ T.unlines - [ "" - , "IdTable" - , " Id Day default=CURRENT_DATE" - , " name Text" - , "" - , "LowerCaseTable" - , " Id sql=my_id" - , " fullName Text" - , " ExtraBlock" - , " foo bar" - , " baz" - , " bin" - , " ExtraBlock2" - , " something" - , "" - , "IdTable" - , " Id Day default=CURRENT_DATE" - , " name Text" - , "" - ] - describe "idTable" $ do - let EntityDef {..} = idTable - it "has no extra blocks" $ do - entityExtra `shouldBe` mempty - it "has the right name" $ do - entityHaskell `shouldBe` HaskellName "IdTable" - it "has the right fields" $ do - map fieldHaskell entityFields `shouldMatchList` - [ HaskellName "name" - ] - describe "lowerCaseTable" $ do - let EntityDef {..} = lowerCaseTable - it "has the right name" $ do - entityHaskell `shouldBe` HaskellName "LowerCaseTable" - it "has the right fields" $ do - map fieldHaskell entityFields `shouldMatchList` - [ HaskellName "fullName" - ] - it "has ExtraBlock" $ do - Map.lookup "ExtraBlock" entityExtra - `shouldBe` Just - [ ["foo", "bar"] - , ["baz"] - , ["bin"] - ] - it "has ExtraBlock2" $ do - Map.lookup "ExtraBlock2" entityExtra - `shouldBe` Just - [ ["something"] - ] - - describe "fromPersistValue" $ - describe "UTCTime" $ - it "works with format" $ - fromPersistValue (PersistText "2018-02-27 10:49:42.123") - `shouldBe` Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) + describe "Database" $ describe "Persist" $ do + THSpec.spec + QuasiSpec.spec + QuasiSpec.warningSpecs + ClassSpec.spec + PersistValueSpec.spec