persistent 2.14.6.3 → 2.18.1.0
raw patch · 86 files changed
Files
- ChangeLog.md +68/−0
- Database/Persist.hs +108/−90
- Database/Persist/Class.hs +100/−95
- Database/Persist/Class/PersistConfig.hs +13/−10
- Database/Persist/Class/PersistEntity.hs +191/−122
- Database/Persist/Class/PersistField.hs +247/−154
- Database/Persist/Class/PersistQuery.hs +56/−33
- Database/Persist/Class/PersistStore.hs +169/−111
- Database/Persist/Class/PersistUnique.hs +141/−101
- Database/Persist/Compatible.hs +2/−3
- Database/Persist/Compatible/TH.hs +183/−48
- Database/Persist/Compatible/Types.hs +97/−27
- Database/Persist/EntityDef.hs +27/−6
- Database/Persist/EntityDef/Internal.hs +3/−2
- Database/Persist/FieldDef.hs +13/−10
- Database/Persist/FieldDef/Internal.hs +3/−3
- Database/Persist/ImplicitIdDef.hs +15/−11
- Database/Persist/ImplicitIdDef/Internal.hs +6/−6
- Database/Persist/Names.hs +10/−9
- Database/Persist/PersistValue.hs +143/−117
- Database/Persist/Quasi.hs +934/−983
- Database/Persist/Quasi/Internal.hs +361/−578
- Database/Persist/Quasi/Internal/ModelParser.hs +983/−0
- Database/Persist/Quasi/Internal/TypeParser.hs +180/−0
- Database/Persist/Quasi/PersistSettings.hs +27/−0
- Database/Persist/Quasi/PersistSettings/Internal.hs +208/−0
- Database/Persist/Sql.hs +49/−28
- Database/Persist/Sql/Class.hs +15251/−1265
- Database/Persist/Sql/Internal.hs +58/−32
- Database/Persist/Sql/Migration.hs +122/−104
- Database/Persist/Sql/Orphan/PersistQuery.hs +399/−249
- Database/Persist/Sql/Orphan/PersistStore.hs +253/−152
- Database/Persist/Sql/Orphan/PersistUnique.hs +68/−50
- Database/Persist/Sql/Raw.hs +105/−79
- Database/Persist/Sql/Run.hs +114/−71
- Database/Persist/Sql/Types.hs +35/−22
- Database/Persist/Sql/Types/Internal.hs +34/−25
- Database/Persist/Sql/Util.hs +78/−59
- Database/Persist/SqlBackend.hs +25/−22
- Database/Persist/SqlBackend/Internal.hs +8/−6
- Database/Persist/SqlBackend/Internal/InsertSqlResult.hs +1/−1
- Database/Persist/SqlBackend/Internal/IsolationLevel.hs +14/−12
- Database/Persist/SqlBackend/Internal/MkSqlBackend.hs +3/−3
- Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs +3/−2
- Database/Persist/SqlBackend/Internal/Statement.hs +8/−6
- Database/Persist/SqlBackend/Internal/StatementCache.hs +2/−1
- Database/Persist/SqlBackend/SqlPoolHooks.hs +91/−56
- Database/Persist/SqlBackend/StatementCache.hs +13/−12
- Database/Persist/TH.hs +52/−3427
- Database/Persist/TH/Internal.hs +4034/−0
- Database/Persist/Types.hs +58/−48
- Database/Persist/Types/Base.hs +297/−264
- Database/Persist/Types/SourceSpan.hs +24/−0
- bench/Main.hs +84/−115
- bench/Models.hs +18/−11
- persistent.cabal +213/−199
- test/Database/Persist/ClassSpec.hs +12/−4
- test/Database/Persist/PersistValueSpec.hs +6/−10
- test/Database/Persist/QuasiSpec.hs +1244/−1217
- test/Database/Persist/TH/CommentSpec.hs +15/−12
- test/Database/Persist/TH/CompositeKeyStyleSpec.hs +22/−21
- test/Database/Persist/TH/DiscoverEntitiesSpec.hs +10/−7
- test/Database/Persist/TH/EmbedSpec.hs +25/−38
- test/Database/Persist/TH/ForeignRefSpec.hs +162/−38
- test/Database/Persist/TH/ImplicitIdColSpec.hs +5/−4
- test/Database/Persist/TH/JsonEncodingSpec.hs +30/−33
- test/Database/Persist/TH/KindEntitiesSpec.hs +6/−2
- test/Database/Persist/TH/MaybeFieldDefsSpec.hs +5/−2
- test/Database/Persist/TH/MigrationOnlySpec.hs +5/−7
- test/Database/Persist/TH/MultiBlockSpec.hs +8/−13
- test/Database/Persist/TH/MultiBlockSpec/Model.hs +1/−2
- test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs +10/−5
- test/Database/Persist/TH/NoFieldSelectorsSpec.hs +5/−5
- test/Database/Persist/TH/OverloadedLabelSpec.hs +11/−6
- test/Database/Persist/TH/PersistWith/Model.hs +4/−1
- test/Database/Persist/TH/PersistWith/Model2.hs +3/−1
- test/Database/Persist/TH/PersistWithSpec.hs +17/−8
- test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs +7/−3
- test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs +16/−16
- test/Database/Persist/TH/SharedPrimaryKeySpec.hs +23/−28
- test/Database/Persist/TH/SumSpec.hs +0/−2
- test/Database/Persist/TH/ToFromPersistValuesSpec.hs +38/−41
- test/Database/Persist/TH/TypeLitFieldDefsSpec.hs +7/−3
- test/Database/Persist/THSpec.hs +172/−125
- test/TemplateTestImports.hs +5/−5
- test/main.hs +1/−0
ChangeLog.md view
@@ -1,5 +1,73 @@ # Changelog for persistent +# 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++# 2.18.0.0++* [#1610](https://github.com/yesodweb/persistent/pull/1610)+ * Added `NoAction` as a `CascadeAction`++# 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)
Database/Persist.hs view
@@ -9,84 +9,105 @@ -- -- If you intend on using a SQL database, then check out "Database.Persist.Sql". module Database.Persist- (--- * Defining Database Models------ | @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.+ ( -- * Defining Database Models --- ** Reference Schema & Dataset------ | 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 |--- > +-----+-----+-----++ -- - -- * Database Operations+ -- | @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++ --++ -- | 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 |+ -- > +-----+-----+-----+++ -- * 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'.+ -- @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@@ -98,19 +119,23 @@ , 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. --@@ -132,7 +157,6 @@ -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+- f =. a = Update f a Assign -- | Assign a field by addition (@+=@).@@ -153,8 +177,6 @@ -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+-- f +=. a = Update f a Add -- | Assign a field by subtraction (@-=@).@@ -175,7 +197,6 @@ -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+- f -=. a = Update f a Subtract -- | Assign a field by multiplication (@*=@).@@ -196,8 +217,6 @@ -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+-- f *=. a = Update f a Multiply -- | Assign a field by division (@/=@).@@ -218,12 +237,16 @@ -- > +-----+-----+---------+ -- > |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. --@@ -241,8 +264,7 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+--f ==. a = Filter f (FilterValue a) Eq+f ==. a = Filter f (FilterValue a) Eq -- | Non-equality check. --@@ -260,7 +282,6 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+- f !=. a = Filter f (FilterValue a) Ne -- | Less-than check.@@ -279,8 +300,7 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+--f <. a = Filter f (FilterValue a) Lt+f <. a = Filter f (FilterValue a) Lt -- | Less-than or equal check. --@@ -298,8 +318,7 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+--f <=. a = Filter f (FilterValue a) Le+f <=. a = Filter f (FilterValue a) Le -- | Greater-than check. --@@ -317,8 +336,7 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+--f >. a = Filter f (FilterValue a) Gt+f >. a = Filter f (FilterValue a) Gt -- | Greater-than or equal check. --@@ -336,11 +354,12 @@ -- > +-----+-----+-----+ -- > |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. --@@ -374,7 +393,6 @@ -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+- f <-. a = Filter f (FilterValues a) In -- | Check if value is not in given list.@@ -393,7 +411,6 @@ -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+- f /<-. a = Filter f (FilterValues a) NotIn infixl 3 ||.@@ -424,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'.@@ -438,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)
Database/Persist/Class.hs view
@@ -9,40 +9,38 @@ -- -- 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 - -- * 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 |- -- > +----+-------+-----++ -- | 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 (..)@@ -56,52 +54,52 @@ , insertEntity , insertRecord - -- * 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 + -- | 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 (..)@@ -118,10 +116,11 @@ , checkUniqueUpdateable , onlyUnique - -- * 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.+ -- * 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@@ -130,17 +129,19 @@ , selectSource , selectKeysList - -- * PersistEntity+ -- * PersistEntity , PersistEntity (..) , tabulateEntity , SymbolToField (..)- -- * PersistField++ -- * PersistField , PersistField (..)- -- * PersistConfig++ -- * PersistConfig , PersistConfig (..) , entityValues - -- * Lifting+ -- * Lifting , HasPersistBackend (..) , withBaseBackend , IsPersistBackend ()@@ -148,17 +149,22 @@ , BackendCompatible (..) , withCompatibleBackend - -- * 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++ -- | '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++ -- * JSON utilities+ , keyValueEntityToJSON+ , keyValueEntityFromJSON+ , entityIdToJSON+ , entityIdFromJSON+ , toPersistValueJSON+ , fromPersistValueJSON ) where import Database.Persist.Class.PersistConfig@@ -167,7 +173,6 @@ 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.
Database/Persist/Class/PersistConfig.hs view
@@ -36,18 +36,21 @@ 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
Database/Persist/Class/PersistEntity.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}-{-# language PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE CPP #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..)@@ -25,39 +25,46 @@ , BackendSpecificFilter , 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++ -- * Safety check for inserts+ , SafeToInsert , SafeToInsertErrorMessage ) where +import Data.Functor.Apply (Apply) import Data.Functor.Constant import Data.Aeson- ( FromJSON(..)- , ToJSON(..)- , Value(Object)- , fromJSON- , object- , withObject- , (.:)- , (.=)- )+ ( FromJSON (..)+ , ToJSON (..)+ , Value (Object)+ , fromJSON+ , object+ , withObject+ , (.:)+ , (.=)+ ) import qualified Data.Aeson.Parser as AP import Data.Aeson.Text (encodeToTextBuilder)-import Data.Aeson.Types (Parser, Result(Error, Success))+import Data.Aeson.Types (Parser, Result (Error, Success)) import Data.Attoparsec.ByteString (parseOnly) import Data.Functor.Identity-import Web.PathPieces (PathMultiPiece(..), PathPiece(..))+import Web.PathPieces (PathMultiPiece (..), PathPiece (..)) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as AM@@ -65,8 +72,8 @@ import qualified Data.HashMap.Strict as AM #endif -import GHC.Records-import Data.List.NonEmpty (NonEmpty(..))+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T@@ -75,8 +82,8 @@ import qualified Data.Text.Lazy.Builder as TB import GHC.Generics import GHC.OverloadedLabels+import GHC.Records import GHC.TypeLits-import Data.Kind (Type) import Database.Persist.Class.PersistField import Database.Persist.Names@@ -96,19 +103,30 @@ -- 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) @@ -122,10 +140,13 @@ -- 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 -> [PersistValue]+ -- | A lower-level operation to convert from database values to a Haskell record. fromPersistValues :: [PersistValue] -> Either Text record @@ -154,24 +175,41 @@ -- -- @since 2.14.0.0 tabulateEntityA- :: Applicative f+ :: (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 -> NonEmpty (FieldNameHS, FieldNameDB)+ 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@@ -188,7 +226,7 @@ -- @since 2.14.6.0 newtype ViaPersistEntity record = ViaPersistEntity (Key record) -instance PersistEntity record => PathMultiPiece (ViaPersistEntity record) where+instance (PersistEntity record) => PathMultiPiece (ViaPersistEntity record) where fromPathMultiPiece pieces = do Right key <- keyFromValues <$> mapM fromPathPiece pieces pure $ ViaPersistEntity key@@ -227,7 +265,7 @@ -- -- @since 2.14.0.0 tabulateEntity- :: PersistEntity record+ :: (PersistEntity record) => (forall a. EntityField record a -> a) -> Entity record tabulateEntity fromField =@@ -236,6 +274,7 @@ type family BackendSpecificUpdate backend record -- Moved over from Database.Persist.Class.PersistUnique+ -- | Textual representation of the record recordName :: (PersistEntity record)@@ -245,22 +284,24 @@ -- | 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 @@ -276,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.@@ -324,27 +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- }+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 @@ -357,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": ...}}@.@@ -373,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@@ -389,10 +437,11 @@ -- 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 $ AM.insert "id" (toJSON key) o- x -> x+ Object o -> Object $ AM.insert "id" (toJSON key) o+ x -> x -- | Predefined @parseJSON@. The input JSON looks like -- @{"id": 1, "name": ...}@.@@ -403,7 +452,8 @@ -- instance FromJSON (Entity User) where -- parseJSON = entityIdFromJSON -- @-entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record)+entityIdFromJSON+ :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) entityIdFromJSON = withObject "entityIdFromJSON" $ \o -> do val <- parseJSON (Object o) k <- case keyFromRecordM of@@ -413,24 +463,26 @@ 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 " `mappend` idField `mappend` " field"- ("_id", kv):afterRest ->+ ("_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: "@@ -451,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@@ -467,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'@@ -498,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@@ -516,11 +571,20 @@ -- @ 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.@@ -550,7 +614,7 @@ -- @OverloadedLabels@ support to the 'EntityField' type. -- -- @since 2.11.0.0-instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where+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@@ -564,25 +628,30 @@ -- 'insertKey'. -- -- @since 2.14.0.0-class SafeToInsert a where+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."+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."+ '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)"+ '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)+instance (TypeError (EntityErrorMessage a)) => SafeToInsert (Entity a)
Database/Persist/Class/PersistField.hs view
@@ -1,51 +1,53 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ module Database.Persist.Class.PersistField ( PersistField (..) , getPersistMap- , OverflowNatural(..)+ , 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.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 GHC.TypeLits-import Data.Ratio (numerator, denominator) 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__@@ -154,7 +156,8 @@ toPersistValue = PersistInt64 fromPersistValue = fromPersistValueIntegral "Int64" "integer" -fromPersistValueIntegral :: Integral a => Text -> Text -> PersistValue -> Either Text a+fromPersistValueIntegral+ :: (Integral a) => Text -> Text -> PersistValue -> Either Text a fromPersistValueIntegral haskellType sqlType pv = case pv of PersistInt64 i -> Right (fromIntegral i)@@ -167,45 +170,57 @@ _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+ 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 -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- ]+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- ]+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@@ -243,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@@ -254,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@@ -279,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 @@ -292,26 +331,49 @@ 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) =- let s = T.unpack t- in- case NonEmpty.nonEmpty (reads 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 parse8601 s <|> parsePretty s of+ case asum+ [parse8601 s, parse8601NoTimezone s, parsePretty s, parsePrettyNoTimezone s] of Nothing -> Left $ fromPersistValueParseError "UTCTime" x Just x' -> Right x' Just matches ->@@ -321,21 +383,22 @@ -- here contains the parsed UTCTime with as much microsecond -- precision parsed as posssible. Right $ fst $ NonEmpty.last matches- where+ 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)- parseTime' = parseTimeM True defaultTimeLocale+parseTime' :: String -> String -> Maybe UTCTime+parseTime' = parseTimeM True defaultTimeLocale #else- parseTime' = parseTime defaultTimeLocale+parseTime' :: String -> String -> Maybe UTCTime+parseTime' = parseTime defaultTimeLocale #endif- parse8601 = parseTime' "%FT%T%Q"- parsePretty = parseTime' "%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@@ -350,37 +413,37 @@ -- non-negative, and are quite efficient for the database to store. -- -- @since 2.11.0-newtype OverflowNatural = OverflowNatural { unOverflowNatural :: Natural }+newtype OverflowNatural = OverflowNatural {unOverflowNatural :: Natural} deriving (Eq, Show, Ord, Num) 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."+ ( 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+ => PersistField Natural+ where toPersistValue = undefined fromPersistValue = undefined 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?+ 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+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)@@ -391,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]) =@@ -407,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 @@ -427,68 +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+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)+ ]
Database/Persist/Class/PersistQuery.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ExplicitForAll #-}+ module Database.Persist.Class.PersistQuery ( selectList , PersistQueryRead (..)@@ -9,14 +10,14 @@ ) 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@@ -29,16 +30,17 @@ -- @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)@@ -51,24 +53,31 @@ -> 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+ 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.@@ -78,10 +87,15 @@ -- streaming, see @persistent-pagination@ for a means of chunking results based -- on indexed ranges. selectSource- :: forall record backend m. (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@@ -91,10 +105,16 @@ -- | Get the 'Key's of all records matching the given criterion. -- -- 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+ :: 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@@ -172,7 +192,8 @@ -- selectList [] ['Asc' UserCreatedAt, 'LimitTo' 10] -- @ selectList- :: forall record backend m. (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend)+ :: forall record backend m+ . (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> ReaderT backend m [Entity record]@@ -181,10 +202,12 @@ liftIO $ with srcRes (\src -> runConduit $ src .| CL.consume) -- | Call 'selectKeys' but return the result as a list.-selectKeysList :: forall record backend m. (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)
Database/Persist/Class/PersistStore.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE TypeOperators #-}+ module Database.Persist.Class.PersistStore ( HasPersistBackend (..) , withBaseBackend@@ -17,8 +18,8 @@ , belongsToJust , insertEntity , insertRecord- , ToBackendKey(..)- , BackendCompatible(..)+ , ToBackendKey (..)+ , BackendCompatible (..) , withCompatibleBackend ) where @@ -53,8 +54,9 @@ -- 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+ :: (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@.@@ -119,12 +121,14 @@ -- that your backend is compatible with. -- -- @since 2.12.0-withCompatibleBackend :: (BackendCompatible sup sub)- => ReaderT sup m a -> ReaderT sub m a+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)@@ -142,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__@@ -176,7 +189,9 @@ -- > +------+-----+ -- > | SPJ | 40 | -- > +------+-----+- get :: forall record m. (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.@@ -202,22 +217,30 @@ -- > | 2 | Simon | 41 | -- > +----+-------+-----+ getMany- :: forall record m. (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). --@@ -241,8 +264,10 @@ -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+- insert :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)- => 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@. --@@ -264,8 +289,10 @@ -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+- insert_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)- => 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.@@ -302,8 +329,10 @@ -- > +-----+------+-----+ -- > |5 |Jane |20 | -- > +-----+------+-----+- insertMany :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)- => [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.@@ -333,8 +362,10 @@ -- > +-----+------+-----+ -- > |5 |Jane |20 | -- > +-----+------+-----+- insertMany_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)- => [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.@@ -365,8 +396,10 @@ -- > +-----+------+-----+ -- > |4 |Eva |38 | -- > +-----+------+-----+- insertEntityMany :: forall record m. (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.@@ -390,8 +423,10 @@ -- > +-----+------+-----+ -- > |3 |Alice |20 | -- > +-----+------+-----+- insertKey :: forall record m. (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@@ -453,8 +488,10 @@ -- > +-----+------+-----+ -- > |3 |X |999 | -- > +-----+------+-----+- repsert :: forall record m. (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. --@@ -484,7 +521,8 @@ -- > |999 |Mr. X |999 | -- > +-----+----------------+---------+ repsertMany- :: forall record m. (MonadIO m, PersistRecordBackend record backend)+ :: forall record m+ . (MonadIO m, PersistRecordBackend record backend) => [(Key record, record)] -> ReaderT backend m () repsertMany = mapM_ (uncurry repsert) @@ -509,8 +547,10 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+- replace :: forall record m. (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.@@ -529,8 +569,10 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+- delete :: forall record m. (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. --@@ -552,8 +594,10 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+- update :: forall record m. (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.@@ -579,13 +623,14 @@ -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+- updateGet :: forall record m. (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. --@@ -612,14 +657,18 @@ -- mrx <- getJustUnknown -- -- This just throws an error.-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+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. --@@ -641,41 +690,46 @@ -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+-getJustEntity :: forall record backend m.- ( PersistEntityBackend record ~ BaseBackend backend- , MonadIO m- , PersistEntity record- , PersistStoreRead backend)- => Key record -> ReaderT backend m (Entity record)+getJustEntity+ :: 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 :: 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+ :: 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 :: forall ent1 ent2 backend m.- ( 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@.@@ -700,13 +754,15 @@ -- > +----+---------+-----+ -- > | 3 | Haskell | 81 | -- > +----+---------+-----+-insertEntity :: forall e backend m.- ( PersistStoreWrite backend- , PersistRecordBackend e backend- , SafeToInsert e- , MonadIO m- , HasCallStack- ) => 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 Maybe.fromMaybe (error errorMessage) <$> getEntity eid@@ -732,11 +788,13 @@ -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+-getEntity :: forall e backend m.- ( 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@@ -766,19 +824,19 @@ -- > |3 |Dave |50 | -- > +-----+------+-----+ insertRecord- :: forall record backend m.- ( PersistEntityBackend record ~ BaseBackend backend- , PersistEntity record- , MonadIO m- , PersistStoreWrite backend- , SafeToInsert record- , HasCallStack- )- => 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- 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-+ 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
Database/Persist/Class/PersistUnique.hs view
@@ -3,11 +3,11 @@ {-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique- ( PersistUniqueRead(..)- , PersistUniqueWrite(..)- , OnlyOneUniqueKey(..)+ ( PersistUniqueRead (..)+ , PersistUniqueWrite (..)+ , OnlyOneUniqueKey (..) , onlyOneUniqueDef- , AtLeastOneUniqueKey(..)+ , AtLeastOneUniqueKey (..) , atLeastOneUniqueDef , NoUniqueKeysError , MultipleUniqueKeysError@@ -23,18 +23,18 @@ , defaultPutMany , persistUniqueKeyValues )- where+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.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (catMaybes, isJust)-import GHC.TypeLits (ErrorMessage(..))+import GHC.TypeLits (ErrorMessage (..)) import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistStore@@ -54,10 +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 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,7 +76,8 @@ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getBy- :: forall record m. (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.@@ -94,7 +96,8 @@ -- -- @since 2.14.5 existsBy- :: forall record m. (MonadIO m, PersistRecordBackend record backend)+ :: forall record m+ . (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m Bool existsBy uniq = isJust <$> getBy uniq @@ -107,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. --@@ -117,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: --@@ -127,7 +132,8 @@ -- > |2 |Simon |41 | -- > +-----+------+-----+ deleteBy- :: forall record m. (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@@ -152,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- :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)+ :: forall record m+ . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum@@ -183,7 +190,8 @@ -- -- @since 2.14.5.0 insertUnique_- :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)+ :: forall record m+ . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => record -> ReaderT backend m (Maybe ()) insertUnique_ datum = do conflict <- checkUnique datum@@ -241,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- :: forall record m. (MonadIO m, PersistRecordBackend record backend, OnlyOneUniqueKey record, SafeToInsert record)+ :: forall record m+ . ( MonadIO m+ , PersistRecordBackend record backend+ , OnlyOneUniqueKey record+ , SafeToInsert record+ ) => record -- ^ new record to insert -> [Update record]@@ -308,7 +321,8 @@ -- > |3 |X |999 | -- > +-----+-----+-----+ upsertBy- :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record)+ :: forall record m+ . (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => Unique record -- ^ uniqueness constraint to find by -> record@@ -326,11 +340,11 @@ -- -- @since 2.8.1 putMany- :: forall record m.- ( MonadIO m- , PersistRecordBackend record backend- , SafeToInsert record- )+ :: 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 ()@@ -342,7 +356,7 @@ -- 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@@ -366,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@@ -377,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." @@ -390,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@@ -404,7 +418,7 @@ -> NonEmpty UniqueDef atLeastOneUniqueDef prxy = case getEntityUniques (entityDef prxy) of- (x:xs) -> x :| xs+ (x : xs) -> x :| xs _ -> error "impossible due to AtLeastOneUniqueKey record constraint" @@ -423,13 +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- :: forall record backend m.- ( MonadIO m- , PersistUniqueWrite backend- , PersistRecordBackend record backend- , AtLeastOneUniqueKey record- , SafeToInsert 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@@ -469,7 +483,6 @@ -- > +----+-------+-----+ -- > | 3 | Alexa | 3 | -- > +----+-------+-----+- insertUniqueEntity :: forall record backend m . ( MonadIO m@@ -480,7 +493,7 @@ => 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. --@@ -497,12 +510,12 @@ -- @onlyUnique@ doesn't work if there're more than two constraints. It will -- fail with a type error instead. onlyUnique- :: forall record backend m.- ( 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 @@ -528,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@@ -548,18 +562,18 @@ -- -- @since 2.10.0 getByValueUniques- :: forall record backend m.- ( 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@@ -574,10 +588,12 @@ -- -- @since 1.2.2.0 replaceUnique- :: forall record backend m. ( 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@@ -609,19 +625,23 @@ -- -- > mSpjConst <- checkUnique $ User "SPJ" 60 checkUnique- :: forall record backend m. ( MonadIO m+ :: forall record backend m+ . ( MonadIO m , PersistRecordBackend record backend- , PersistUniqueRead backend)+ , PersistUniqueRead backend+ ) => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys checkUniqueKeys- :: forall record backend m. ( MonadIO m+ :: forall record backend m+ . ( MonadIO m , PersistUniqueRead backend- , PersistRecordBackend record 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@@ -651,27 +671,31 @@ -- -- @since 2.11.0.0 checkUniqueUpdateable- :: forall record backend m. ( MonadIO m+ :: forall record backend m+ . ( MonadIO m , PersistRecordBackend record backend- , PersistUniqueRead 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+ :: forall record backend m+ . ( MonadIO m , PersistUniqueRead backend- , PersistRecordBackend record backend)+ , PersistRecordBackend record backend+ ) => Key record -> [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeysUpdateable _ [] = return Nothing-checkUniqueKeysUpdateable key (x:xs) = do+checkUniqueKeysUpdateable key (x : xs) = do y <- getBy x case y of Nothing -> checkUniqueKeysUpdateable key xs Just (Entity k _)- | key == k ->- checkUniqueKeysUpdateable key xs+ | key == k ->+ checkUniqueKeysUpdateable key xs Just _ -> return (Just x) @@ -688,10 +712,14 @@ , 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+ => 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@@ -704,17 +732,18 @@ -- * For pre-existing records, issue a 'replace' for each old key and new record -- * For new records, issue a bulk 'insertMany_' defaultPutMany- :: forall record backend m. ( PersistEntityBackend record ~ BaseBackend backend- , PersistEntity record- , MonadIO m- , PersistStoreWrite backend- , PersistUniqueRead backend- , SafeToInsert record- )+ :: 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@@ -723,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@@ -756,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
Database/Persist/Compatible.hs view
@@ -1,9 +1,8 @@ module Database.Persist.Compatible- ( Compatible(..)+ ( Compatible (..) , makeCompatibleInstances , makeCompatibleKeyInstances ) where -import Database.Persist.Compatible.Types import Database.Persist.Compatible.TH-+import Database.Persist.Compatible.Types
Database/Persist/Compatible/TH.hs view
@@ -31,33 +31,70 @@ -- @since 2.12 makeCompatibleInstances :: Q Type -> Q [Dec] makeCompatibleInstances compatibleType = do- (b, s) <- compatibleType >>= \case+ (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`"+ 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`"+ 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)- |]+ [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'. --@@ -73,35 +110,133 @@ -- @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`"+ (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))+ 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)) |]
Database/Persist/Compatible/Types.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -Wno-unused-top-binds #-} {- You can't export a data family constructor, so there's an "unused" warning -} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,9 +6,10 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Database.Persist.Compatible.Types- ( Compatible(..)+ ( Compatible (..) ) where import Control.Monad.Trans.Reader (withReaderT)@@ -17,7 +17,6 @@ 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,@@ -53,14 +52,17 @@ -- @ -- -- @since 2.12-newtype Compatible b s = Compatible { unCompatible :: s }+newtype Compatible b s = Compatible {unCompatible :: s} -instance (BackendCompatible b s, HasPersistBackend b) => HasPersistBackend (Compatible b s) where+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@.+ -- \| 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@.@@ -85,28 +87,44 @@ -- -- 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 }+ newtype BackendKey (Compatible b s) = CompatibleKey {unCompatibleKey :: BackendKey b} -instance (HasPersistBackend b, BackendCompatible b s, PersistStoreRead b) => PersistStoreRead (Compatible b s) where+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+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+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+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+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@@ -120,23 +138,75 @@ 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+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))+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))
Database/Persist/EntityDef.hs view
@@ -5,7 +5,9 @@ module Database.Persist.EntityDef ( -- * The 'EntityDef' type EntityDef+ -- * Construction+ -- * Accessors , getEntityHaskellName , getEntityDBName@@ -19,17 +21,21 @@ , getEntityKeyFields , getEntityComments , getEntityExtra+ , getEntitySpan , isEntitySum , entityPrimary , entitiesPrimary , keyAndEntityFields- -- * Setters+ , keyAndEntityFieldsDatabase++ -- * Setters , setEntityId , setEntityIdDef , setEntityDBName , overEntityFields+ -- * Related Types- , EntityIdDef(..)+ , EntityIdDef (..) ) where import Data.List.NonEmpty (NonEmpty)@@ -40,7 +46,12 @@ import Database.Persist.FieldDef import Database.Persist.Names-import Database.Persist.Types.Base (ForeignDef, UniqueDef(..), entityKeyFields)+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@@ -93,7 +104,7 @@ -- -- @since 2.13.0.0 setEntityDBName :: EntityNameDB -> EntityDef -> EntityDef-setEntityDBName db ed = ed { entityDB = db }+setEntityDBName db ed = ed{entityDB = db} getEntityComments :: EntityDef -> Maybe Text getEntityComments = entityComments@@ -179,7 +190,7 @@ :: EntityIdDef -> EntityDef -> EntityDef-setEntityIdDef i ed = ed { entityId = i }+setEntityIdDef i ed = ed{entityId = i} -- | --@@ -193,7 +204,7 @@ -- -- @since 2.13.0.0 setEntityFields :: [FieldDef] -> EntityDef -> EntityDef-setEntityFields fd ed = ed { entityFields = fd }+setEntityFields fd ed = ed{entityFields = fd} -- | Perform a mapping function over all of the entity fields, as determined by -- 'getEntityFieldsDatabase'.@@ -205,3 +216,13 @@ -> 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
Database/Persist/EntityDef/Internal.hs view
@@ -7,12 +7,13 @@ -- -- @since 2.13.0.0 module Database.Persist.EntityDef.Internal- ( EntityDef(..)+ ( EntityDef (..) , entityPrimary , entitiesPrimary , keyAndEntityFields+ , keyAndEntityFieldsDatabase , toEmbedEntityDef- , EntityIdDef(..)+ , EntityIdDef (..) ) where import Database.Persist.Types.Base
Database/Persist/FieldDef.hs view
@@ -4,44 +4,47 @@ module Database.Persist.FieldDef ( -- * The 'FieldDef' type FieldDef+ -- ** Setters , setFieldAttrs , overFieldAttrs , addFieldAttr+ -- ** Helpers , isFieldNullable , isFieldMaybe , isFieldNotGenerated , isHaskellField+ -- * 'FieldCascade'- , FieldCascade(..)+ , FieldCascade (..) , renderFieldCascade , renderCascadeAction , noCascade- , CascadeAction(..)+ , CascadeAction (..) ) where import Database.Persist.FieldDef.Internal import Database.Persist.Types.Base- ( FieldAttr(..)- , FieldType(..)- , IsNullable(..)- , fieldAttrsContainsNullable- , isHaskellField- )+ ( 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 }+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) }+overFieldAttrs k fd = fd{fieldAttrs = k (fieldAttrs fd)} -- | Add an attribute to the list of field attributes. --
Database/Persist/FieldDef/Internal.hs view
@@ -2,13 +2,13 @@ -- -- @since 2.13.0.0 module Database.Persist.FieldDef.Internal- ( FieldDef(..)+ ( FieldDef (..) , isFieldNotGenerated- , FieldCascade(..)+ , FieldCascade (..) , renderFieldCascade , renderCascadeAction , noCascade- , CascadeAction(..)+ , CascadeAction (..) ) where import Database.Persist.Types.Base
Database/Persist/ImplicitIdDef.hs view
@@ -13,25 +13,29 @@ module Database.Persist.ImplicitIdDef ( -- * The Type ImplicitIdDef+ -- * Construction , mkImplicitIdDef- -- * Autoincrementing Integer Key++ -- * Autoincrementing Integer Key , autoIncrementingInteger- -- * Getters- -- * Setters++ -- * 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(..)+ ( FieldType (..)+ , SqlType (..) )-import Database.Persist.Class (BackendKey)-import Database.Persist.Names -- | 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@@ -46,10 +50,10 @@ , iidFieldSqlType = SqlInt64 , iidType = \isMpsGeneric mpsBackendType ->- ConT ''BackendKey `AppT`- if isMpsGeneric- then VarT (mkName "backend")- else mpsBackendType+ ConT ''BackendKey+ `AppT` if isMpsGeneric+ then VarT (mkName "backend")+ else mpsBackendType , iidDefault = Nothing , iidMaxLen =
Database/Persist/ImplicitIdDef/Internal.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-}-{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} -- | WARNING: This is an @Internal@ module. As such, breaking changes to the API@@ -16,14 +15,14 @@ -- @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 Data.Typeable (eqT)-import Data.Foldable (asum) import Database.Persist.Class.PersistField (PersistField) import Database.Persist.Names@@ -152,7 +151,8 @@ -- -- @since 2.13.0.0 mkImplicitIdDef- :: forall t. (Typeable t, PersistFieldSql t)+ :: forall t+ . (Typeable t, PersistFieldSql t) => Text -- ^ The default expression to use for columns. Should be valid SQL in the -- language you're using.@@ -186,7 +186,7 @@ :: Integer -> ImplicitIdDef -> ImplicitIdDef-setImplicitIdDefMaxLen i iid = iid { iidMaxLen = Just i }+setImplicitIdDefMaxLen i iid = iid{iidMaxLen = Just i} -- | This function converts a 'Typeable' type into a @persistent@ -- representation of the type of a field - 'FieldTyp'.@@ -224,4 +224,4 @@ -- -- @since 2.13.0.0 unsafeClearDefaultImplicitId :: ImplicitIdDef -> ImplicitIdDef-unsafeClearDefaultImplicitId iid = iid { iidDefault = Nothing }+unsafeClearDefaultImplicitId iid = iid{iidDefault = Nothing}
Database/Persist/Names.hs view
@@ -8,6 +8,7 @@ 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 ()@@ -22,7 +23,7 @@ -- will use for a field. -- -- @since 2.12.0.0-newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text }+newtype FieldNameDB = FieldNameDB {unFieldNameDB :: Text} deriving (Show, Eq, Read, Ord, Lift) -- | @since 2.12.0.0@@ -33,21 +34,21 @@ -- will use for a field. -- -- @since 2.12.0.0-newtype FieldNameHS = FieldNameHS { unFieldNameHS :: Text }+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 }+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 }+newtype EntityNameDB = EntityNameDB {unEntityNameDB :: Text} deriving (Show, Eq, Read, Ord, Lift) instance DatabaseName EntityNameDB where@@ -57,16 +58,16 @@ -- will use for a constraint. -- -- @since 2.12.0.0-newtype ConstraintNameDB = ConstraintNameDB { unConstraintNameDB :: Text }- deriving (Show, Eq, Read, Ord, Lift)+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+ 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)+newtype ConstraintNameHS = ConstraintNameHS {unConstraintNameHS :: Text}+ deriving (Show, Eq, Read, Ord, Lift)
Database/Persist/PersistValue.hs view
@@ -1,33 +1,33 @@-{-# LANGUAGE PatternSynonyms #-} {-# 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)+ ( PersistValue (.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific) , fromPersistValueText- , LiteralType(..)+ , 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.Text.Encoding as TE import qualified Data.ByteString.Char8 as BS8-import qualified Data.Vector as V import Data.Int (Int64) import qualified Data.Scientific-import Data.Text.Encoding.Error (lenientDecode)-import Data.Bits (shiftL, shiftR)-import Numeric (readHex, showHex)-import qualified Data.Text as Text import Data.Text (Text)-import Data.ByteString as BS (ByteString, foldl')+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 Web.PathPieces (PathPiece(..))-import qualified Data.Aeson as A-import qualified Data.ByteString as BS+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@@ -37,11 +37,11 @@ #endif import Web.HttpApiData- ( FromHttpApiData(..)- , ToHttpApiData(..)- , parseUrlPieceMaybe- , readTextData- )+ ( FromHttpApiData (..)+ , ToHttpApiData (..)+ , parseUrlPieceMaybe+ , readTextData+ ) -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'.@@ -58,62 +58,61 @@ | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)]- | PersistObjectId ByteString- -- ^ Intended especially for MongoDB backend- | PersistArray [PersistValue]- -- ^ Intended especially for PostgreSQL backend for text arrays- | PersistLiteral_ LiteralType ByteString- -- ^ 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+ | -- | 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-+ 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- = Escaped- -- ^ The accompanying value will be escaped before inserting into the- -- database. This is the correct default choice to use.- --- -- @since 2.12.0.0- | Unescaped- -- ^ 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- | DbSpecific- -- ^ 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+ = -- | 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@@ -129,8 +128,9 @@ -- -- @since 2.12.0.0 pattern PersistDbSpecific :: ByteString -> PersistValue-pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where- PersistDbSpecific bs = PersistLiteral_ DbSpecific bs+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@@ -139,8 +139,9 @@ -- -- @since 2.12.0.0 pattern PersistLiteralEscaped :: ByteString -> PersistValue-pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where- PersistLiteralEscaped bs = PersistLiteral_ Escaped bs+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@@ -149,10 +150,14 @@ -- -- @since 2.12.0.0 pattern PersistLiteral :: ByteString -> PersistValue-pattern PersistLiteral bs <- PersistLiteral_ _ bs where- PersistLiteral bs = PersistLiteral_ Unescaped bs+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." #-}+{-# 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@@ -169,22 +174,25 @@ instance ToHttpApiData PersistValue where toUrlPiece val = case fromPersistValueText val of- Left e -> error $ Text.unpack e+ Left e -> error $ Text.unpack e Right y -> y instance FromHttpApiData PersistValue where parseUrlPiece input =- PersistInt64 <$> parseUrlPiece input- <!> PersistList <$> readTextData input- <!> PersistText <$> return input+ PersistInt64+ <$> parseUrlPiece input+ <!> PersistList+ <$> readTextData input+ <!> PersistText+ <$> return input where infixl 3 <!> Left _ <!> y = y- x <!> _ = x+ x <!> _ = x instance PathPiece PersistValue where- toPathPiece = toUrlPiece- fromPathPiece = parseUrlPieceMaybe+ toPathPiece = toUrlPiece+ fromPathPiece = parseUrlPieceMaybe fromPersistValueText :: PersistValue -> Either Text Text fromPersistValueText (PersistText s) = Right s@@ -217,9 +225,11 @@ 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)+ where+ go (k, v) = (keyFromText k, A.toJSON v) toJSON (PersistLiteral_ litTy b) =- let encoded = TE.decodeUtf8 $ B64.encode b+ let+ encoded = TE.decodeUtf8 $ B64.encode b prefix = case litTy of DbSpecific -> 'p'@@ -229,63 +239,80 @@ 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+ 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 #-}+ -- 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+ -- 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 ('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 ('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 ('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+ headMay [] = Nothing+ headMay (x : _) = Just x readMay t = case reads $ Text.unpack t of- (x, _):_ -> return x+ (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 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)+ 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.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)@@ -293,4 +320,3 @@ fmap PersistMap $ mapM go $ AM.toList o where go (k, v) = (,) (keyToText k) <$> A.parseJSON v-
Database/Persist/Quasi.hs view
@@ -4,986 +4,937 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-|-This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities.--The basic structure of the syntax looks like this:--> TableName-> fieldName FieldType-> otherField String-> nullableField Int Maybe--You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type.--@persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL:--> CREATE TABLE table_name (-> id SERIAL PRIMARY KEY,-> field_name field_type NOT NULL,-> other_field varchar NOT NULL,-> nullable_field int NULL-> );--Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function.--It generates a Haskell datatype with the following form:--@-data TableName = TableName- { tableNameFieldName :: FieldType- , tableNameOtherField :: String- , tableNameNullableField :: Maybe Int- }-@--As with the SQL generated, the specifics of this are customizable.-See the "Database.Persist.TH" module for details.--= Deriving--You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that.-Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses.--> User-> name String-> age Int-> deriving Eq Show-> deriving Ord--= Unique Keys--You can define a uniqueness key on a table with the following format:--> User-> name String-> age Int->-> UniqueUserName name--This will put a unique index on the @user@ table and the @name@ field.--= Setting defaults--You can use a @default=${sql expression}@ clause to set a default for a field.-The thing following the @=@ is interpreted as SQL that will be put directly into the table definition.--@-User- name Text- admin Bool default=false-@--This creates a SQL definition like this:--> CREATE TABLE user (-> id SERIAL PRIMARY KEY,-> name VARCHAR NOT NULL,-> admin BOOL DEFAULT=false-> );--A restriction here is that you still need to provide a value when performing an @insert@, because the generated Haskell type has the form:--@-data User = User- { userName :: Text- , userAdmin :: Bool- }-@--You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default.--__Note__: Persistent determines whether or not to migrate a column's default-value by comparing the exact string found in your @models@ file with the one-returned by the database. If a database canonicalizes the SQL @FALSE@ from your-@models@ file to @false@ in the database, Persistent will think the default-value needs to be migrated and-<https://github.com/yesodweb/persistent/issues/241 attempt a migration each time you start your app>.--To workaround this, find the exact SQL your DBMS uses for the default value. For example, using postgres:--@-psql database_name # Open postgres--\\d+ table_name -- describe the table schema-@--@-...-created | timestamp without time zone | not null default now()-@--Then use the listed default value SQL inside your @models@ file.--= Custom ID column--If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field.-This @User@ has a @Text@ ID.--> User-> Id Text-> name Text-> age Int--If you do this, it's a good idea to set a default for the ID.-Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts.--@-'insertKey' (UserKey "Hello world!") (User "Bob" 32)-@--If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore.-So instead just use a default expression, like this:--@-User- Id Text default=generate_user_id()- name Text- age Int-@--= Custom Primary Keys--Sometimes you don't want to have an ID column, and you want a different sort of primary key.-This is a table that stores unique email addresses, and the email is the primary key.-We store the first and second part (eg @first\@second@) separately.--@-Email- firstPart Text- secondPart Text-- Primary firstPart secondPart-@--This creates a table with the following form:--@-CREATE TABLE email (- first_part varchar,- second_part varchar,-- PRIMARY KEY (first_part, second_part)-@--Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo.-As a key with multiple fields, it is also a "composite key."--You can specify a @Primary@ key with a single field, too.--= Overriding SQL--You can use a @sql=custom@ annotation to provide some customization on the entity and field.-For example, you might prefer to name a table differently than what @persistent@ will do by default.-You may also prefer to name a field differently.--@-User sql=big_user_table- fullName String sql=name- age Int-@--This will alter the generated SQL to be:--@-CREATE TABEL big_user_table (- id SERIAL PRIMARY KEY,- name VARCHAR,- age INT-);-@--= Customizing Types/Tables--== JSON instances--You can automatically get ToJSON and FromJSON instances for any entity by adding @json@ to the entity line:--@-Person json- name Text-@-Requires @\{\-\# LANGUAGE FlexibleInstances \#\-\}@--Customizable by using mpsEntityJSON-* http://hackage.haskell.org/package/persistent-template/docs/Database-Persist-TH.html#v:EntityJSON-* http://hackage.haskell.org/package/persistent/docs/Database-Persist-Class.html#v:keyValueEntityToJSON--== Changing table/collection name--@-Person sql=peoples- name Text-@--== Change table/collection key definition (field name and\/or type, persistent >= 2.1)--@Id@ defines the column to use to define the key of the entity.-Without type, the default backend key type will be used. You can change its-database name using the @sql@ attributes :--@-Person- Id sql=my_id_name- phone Text-@--With a Haskell type, the corresponding type is used. Note that you'll need to-use @default=@ to tell it what to do on insertion.--@-Person- Id Day default=CURRENT_DATE- phone Text-@--@default=@ works for SQL databases, and is backend specific.-For MongoDB currently one always needs to create the key on the application-side and use @insertKey@. @insert@ will not work correctly. Sql backends can-also do this if default does not work.--@sqltype@ can also be used to specify a different database type--@-Currency- Id String sqltype=varchar(3) sql=code-@--Composite key (using multiple columns) can also be defined using @Primary@.--@sql=@ also works for setting the names of unique indexes.--@-Person- name Text- phone Text- UniquePersonPhone phone sql=UniqPerPhone-@--This makes a unique index requiring @phone@ to be unique across @Person@ rows.-Ordinarily Persistent will generate a snake-case index name from the-capitalized name provided such that @UniquePersonPhone@ becomes-@unique_person_phone@. However, we provided a @sql=@ so the index name in the-database will instead be @UniqPerPhone@. Keep in mind @sql=@ and @!@ attrs must-come after the list of fields in front of the index name in the quasi-quoter.----= Customizing Fields--== Nullable Fields--As illustrated in the example at the beginning of this page, we are able to represent nullable-fields by including 'Maybe' at the end of the type declaration:--> TableName-> fieldName FieldType-> otherField String-> nullableField Int Maybe--Alternatively we can specify the keyword nullable:--> TableName-> fieldName FieldType-> otherField String-> nullableField Int nullable--However the difference here is in the first instance the Haskell type will be 'Maybe Int',-but in the second it will be 'Int'. Be aware that this will cause runtime errors if the-database returns @NULL@ and the @PersistField@ instance does not handle @PersistNull@.--If you wish to define your Maybe types in a way that is similar to the actual Haskell-definition, you can define 'Maybe Int' like so:--> TableName-> fieldName FieldType-> otherField String-> nullableField (Maybe Int)--However, note, the field _must_ be enclosed in parenthesis.--== @sqltype=@--By default, Persistent maps the Haskell types you specify in the Models DSL to-an appropriate SQL type in the database (refer to the section "Conversion table-(migrations)" for the default mappings). Using the-@sqltype=@ option, you can customize the SQL type Persistent uses for your-column. Use cases include:--* Interacting with an existing database whose column types don't match Persistent's defaults.-* Taking advantage of a specific SQL type's features- * e.g. Using an equivalent type that has better space or performance characteristics--To use this setting, add the @sqltype=@ option after declaring your field name and type:--@-User- username Text sqltype=varchar(255)-@--== Laziness--By default the records created by persistent have strict fields. You can prefix-a field name with @~@ to make it lazy (or @!@ to make it strict).--== Attributes--The QuasiQuoter allows you to provide arbitrary attributes to an entity or field.-This can be used to extend the code in ways that the library hasn't anticipated.-If you use this feature, we'd definitely appreciate hearing about it and-potentially supporting your use case directly!--@-User !funny- field String !sad- good Dog !sogood-@--We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field.--@-userAttrs = do- let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User)- let userAttributes = 'entityAttrs' userDefinition- let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition)- print userAttributes--- ["funny"]- print fieldAttributes--- [["sad"],["sogood"]]-@--== @!no-migrate@--To prevent @migrateModels@ from generating _any_ migrations for an entity, add-the @!no-migrate@ attribute to it's definition:--@-User !no-migrate- field String- good Dog-@--== @MigrationOnly@--Introduced with @persistent-template@ 1.2.0. The purpose of this attribute is-to mark a field which will be entirely ignored by the normal processing, but-retained in the database definition for purposes of migration. This means, in-SQL, a column will not be flagged for removal by the migration scripts, even-though it is not used in your code. This is useful for phasing out usage of a-column before entirely removing it, or having columns which are needed by other-tools but not by Persistent.--@-Person- name Text- age Int- unusedField ByteString Maybe MigrationOnly-@--Note that you almost certainly want to either mark the field as @Maybe@ or-provide a default value, otherwise insertions will fail.---== @SafeToRemove@--This is intended to be used as part of a deprecation of a field, after-@MigrationOnly@ has been used usually. This works somewhat as a superset of the-functionality of @MigrationOnly@. In addition, the field will be removed from-the database if it is present. Note that this is a destructive change which you-are marking as safe.--== Constraints--Migration will remove any manual constraints from your tables. Exception: constraints whose names begin with the string @__manual_@ (which starts with two underscores) will be preserved.---= Foreign Keys--If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly.--@-Person- name Text--Dog- name Text- owner PersonId-@--This automatically creates a foreign key reference from @Dog@ to @Person@.-The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database.-If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred.--== @constraint=@--You can use the @constraint=@ attribute to override the constraint name used in-migrations. This is useful particularly when the automatically generated-constraint names exceed database limits (e.g. MySQL does not allow constraint-names longer than 64 characters).--@-VeryLongTableName- name Text--AnotherVeryLongTableName- veryLongTableNameId VeryLongTableNameId constraint=short_foreign_key-@--== OnUpdate and OnDelete--These options affects how a referring record behaves when the target record is changed.-There are several options:--* 'Restrict' - This is the default. It prevents the action from occurring.-* 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too.-* 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys.-* 'SetDefault' - This will set the column's value to the @default@ for the column, if specified.--To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action.--@-Record- -- If the referred Foo is deleted or updated, then this record will- -- also be deleted or updated.- fooId FooId OnDeleteCascade OnUpdateCascade-- -- If the referred Bar is deleted, then we'll set the reference to- -- 'Nothing'. If the referred Bar is updated, then we'll cascade the- -- update.- barId BarId Maybe OnDeleteSetNull OnUpdateCascade-- -- If the referred Baz is deleted, then we set to the default ID.- bazId BazId OnDeleteSetDefault default=1-@--Let's demonstrate this with a shopping cart example.--@-User- name Text--Cart- user UserId Maybe--CartItem- cartId CartId- itemId ItemId--Item- name Text- price Int-@--Let's consider how we want to handle deletions and updates.-If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@.--@-Cart- user UserId Maybe OnDeleteCascade OnUpdateCascade-@--If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database.-If a @Cart@ is deleted, though, then we just want to delete the @CartItem@.--@-CartItem- cartId CartId OnDeleteCascade- itemId ItemId OnDeleteSetDefault default=1-@--== @Foreign@ keyword--The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword.--A pseudo formal syntax for @Foreign@ is:--@-Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ]--columns := column0 [column1 column2 .. columnX]-references := References $(target-columns)-target-columns := target-column0 [target-column1 target-columns2 .. target-columnX]-@--Columns are the columns as defined on this entity.-@target-columns@ are the columns as defined on the target entity.--Let's look at some examples.--=== Composite Primary Key References--The most common use for this is to refer to a composite primary key.-Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column.--@-Email- firstPart Text- secondPart Text- Primary firstPart secondPart--User- name Text- emailFirstPart Text- emailSecondPart Text-- Foreign Email fk_user_email emailFirstPart emailSecondPart-@--If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key.-If we wanted to be fully redundant, we could specify the @References@ keyword.--@- Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart-@--We can specify delete/cascade behavior directly after the target table.--@- Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart-@--Now, if the email is deleted or updated, the user will be deleted or updated to match.--=== Non-Primary Key References--SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint.-Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent.-To do this, we must use the @References@ keyword.--@-User- name Text- email Text-- UniqueEmail email--Notification- content Text- sentTo Text-- Foreign User fk_noti_user sentTo References email-@--If the target uniqueness constraint has multiple columns, then you must specify them independently.--@-User- name Text- emailFirst Text- emailSecond Text-- UniqueEmail emailFirst emailSecond--Notification- content Text- sentToFirst Text- sentToSecond Text-- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond-@--= Documentation Comments--The quasiquoter supports ordinary comments with @--@ and @#@.-Since @persistent-2.10.5.1@, it also supports documentation comments.-The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions:--1. Only the @-- | @ form is allowed.-2. You must put a space before and after the @|@ pipe character.-3. The comment must be indented at the same level as the entity or field it documents.--An example of the field documentation is:--@--- | I am a doc comment for a User. Users are important--- | to the application, and should be treasured.-User- -- | Users have names. Call them by names.- name String- -- | A user can be old, or young, and we care about- -- | this for some reason.- age Int-@--The documentation is present on the @entityComments@ field on the @EntityDef@ for the entity:--@->>> let userDefinition = entityDef (Proxy :: Proxy User)->>> entityComments userDefinition-"I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n"-@--Likewise, the field documentation is present in the @fieldComments@ field on the @FieldDef@ present in the @EntityDef@:--@->>> let userFields = entityFields userDefinition->>> let comments = map fieldComments userFields->>> mapM_ putStrLn comments-"Users have names. Call them by names."-"A user can be old, or young, and we care about\nthis for some reason."-@--Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False).-@persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.--= Sum types--== Field level--You'll frequently want to store an enum of values in your database. For-example, you might describe a @Person@'s employment status as being @Employed@,-@Unemployed@, or @Retired@. In Haskell this is represented with a sum type, and-Persistent provides a Template Haskell function to marshall these values to and-from the database:--@--- @Employment.hs-{-# LANGUAGE TemplateHaskell #-}-module Employment where--import Database.Persist.TH-import Prelude--data Employment = Employed | Unemployed | Retired- deriving (Show, Read, Eq)-derivePersistField "Employment"-@--@derivePersistField@ stores sum type values as strins in the database. While not as efficient as using integers, this approach simplifies adding and removing values from your enumeration.--Due to the GHC Stage Restriction, the call to the Template Haskell function @derivePersistField@ must be in a separate module than where the generated code is used.--Note: If you created a new module, make sure add it to the @exposed-modules@ section of your Cabal file.--Use the module by importing it into your @Model.hs@ file:--@--- @Model.hs-import Employment-@--and use it in the @models@ DSL:--@-Person- employment Employment-@--You can export the Employment module from Import to use it across your app:--@--- @Import.hs-import Employment as Import-@--=== Entity-level--NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints).--The-<https://github.com/yesodweb/persistent/blob/master/persistent-test/src/SumTypeTest.hs#L35 tests for this feature>-demonstrate their usage. Note the use of the sign @+@ in front of the entity-name.--The schema in the test is reproduced here:--@-share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase|-Bicycle- brand T.Text-Car- make T.Text- model T.Text-+Vehicle- bicycle BicycleId- car CarId-|]-@--Let's check out the definition of the Haskell type @Vehicle@.-Using @ghci@, we can query for @:info Vehicle@:-->>> :i Vehicle-type Vehicle = VehicleGeneric SqlBackend- -- Defined at .../Projects/persistent/persistent-test/src/SumTypeTest.hs:26:1-->>> :i VehicleGeneric-type role VehicleGeneric nominal-data VehicleGeneric backend- = VehicleBicycleSum (Key (BicycleGeneric backend))- | VehicleCarSum (Key (CarGeneric backend))- -- Defined at .../persistent/persistent-test/src/SumTypeTest.hs:26:1--- lots of instances follow...--A @VehicleGeneric@ has two constructors:--- @VehicleBicycleSum@ with a @Key (BicycleGeneric backend)@ field-- @VehicleCarSum@ with a @Key (CarGeneric backend)@ field--The @Bicycle@ and @Car@ are typical @persistent@ entities.--This generates the following SQL migrations (formatted for readability):--@-CREATE TABLE "bicycle" (- "id" INTEGER PRIMARY KEY,- "brand" VARCHAR NOT NULL-);--CREATE TABLE "car"(- "id" INTEGER PRIMARY KEY,- "make" VARCHAR NOT NULL,- "model" VARCHAR NOT NULL-);--CREATE TABLE "vehicle"(- "id" INTEGER PRIMARY KEY,- "bicycle" INTEGER NULL REFERENCES "bicycle",- "car" INTEGER NULL REFERENCES "car"-);-@--The @vehicle@ table contains a nullable foreign key reference to both the bicycle and the car tables.--A SQL query that grabs all the vehicles from the database looks like this (note the @??@ is for the @persistent@ raw SQL query functions):--@-SELECT ??, ??, ??-FROM vehicle-LEFT JOIN car- ON vehicle.car = car.id-LEFT JOIN bicycle- ON vehicle.bicycle = bicycle.id-@--If we use the above query with @rawSql@, we'd get the following result:--@-getVehicles- :: SqlPersistM- [ ( Entity Vehicle- , Maybe (Entity Bicycle)- , Maybe (Entity Car)- )- ]-@--This result has some post-conditions that are not guaranteed by the types *or* the schema.-The constructor for @Entity Vehicle@ is going to determine which of the other members of the tuple is @Nothing@.-We can convert this to a friendlier domain model like this:--@-data Vehicle'- = Car' Text Text- | Bike Text--check = do- result <- getVehicles- pure (map convert result)--convert- :: (Entity Vehicle, Maybe (Entity Bicycle), Maybe (Entity Car))- -> Vehicle'-convert (Entity _ (VehicycleBicycleSum _), Just (Entity _ (Bicycle brand)), _) =- Bike brand-convert (Entity _ (VehicycleCarSum _), _, Just (Entity _ (Car make model))) =- Car make model-convert _ =- error "The database preconditions have been violated!"-@--== Times with timezones--Storing times with timezones in one type in databases is not possible, although-it seems that it should be possible (@timezone@ and @timezonetz@ in-PostgreSQL). That's why starting with persistent 2.0, all times will be mapped-to @UTCTime@. If you need to store timezone information along with times in a-database, store the timezone in a second field. Here are some links about the-topic with further information:--* https://github.com/yesodweb/persistent/issues/290-* https://groups.google.com/forum/#!msg/yesodweb/MIfcV2bwM80/8QLFpgp1LykJ-* http://stackoverflow.com/questions/14615271/postgres-timestamp/14616640#14616640-* http://justatheory.com/computers/databases/postgresql/use-timestamptz.html-* https://github.com/lpsmith/postgresql-simple/issues/69-* https://github.com/nikita-volkov/hasql-postgres/issues/1--= Conversion table (migrations)--Here are the conversions between Haskell types and database types:--+------------+----------------------+-------------------+---------------+----------------+-| Haskell | PostgreSQL | MySQL | MongoDB | SQLite |-+============+======================+===================+===============+================+-| Text | VARCHAR | TEXT | String | VARCHAR |-+------------+----------------------+-------------------+---------------+----------------+-| ByteString | BYTEA | BLOB | BinData | BLOB |-+------------+----------------------+-------------------+---------------+----------------+-| Int | INT8 | BIGINT(20) | NumberLong | INTEGER |-+------------+----------------------+-------------------+---------------+----------------+-| Double | DOUBLE PRECISION | DOUBLE | Double | REAL |-+------------+----------------------+-------------------+---------------+----------------+-| Rational | NUMERIC(22, 12) | DECIMAL(32,20) | *Unsupported* | NUMERIC(32,20)|-+------------+----------------------+-------------------+---------------+----------------+-| Bool | BOOLEAN | TINYINT(1) | Boolean | BOOLEAN |-+------------+----------------------+-------------------+---------------+----------------+-| Day | DATE | DATE | NumberLong | DATE |-+------------+----------------------+-------------------+---------------+----------------+-| TimeOfDay | TIME | TIME\*\* | *Unsupported* | TIME |-+------------+----------------------+-------------------+---------------+----------------+-| UTCTime\* | TIMESTAMP | DATETIME\*\* | Date | TIMESTAMP |-+------------+----------------------+-------------------+---------------+----------------+--Notes:--\* Support for @ZonedTime@ was dropped in persistent 2.0. @UTCTime@ can be used-with @timestamp without timezone@ and @timestamp with timezone@ in PostgreSQL.-See also the section "Times with timezones".--\*\* The default resolution for @TIME@ and @DATETIME@ in MySQL is one second.-As of MySQL version 5.6.4, and persistent-mysql-2.6.2, fractional seconds are-handled correctly if you declare an explicit precision by using @sqltype@. For-example, appending @sqltype=TIME(6)@ to a @TimeOfDay@ field definition will-give microsecond resolution.--= Compatibility tables--MySQL:--+-------------------+-----------------------------------------------------------------------+-|Haskell type | Compatible MySQL types |-+===================+=======================================================================+-| Bool | Tiny |-+-------------------+-----------------------------------------------------------------------+-| Int8 | Tiny |-+-------------------+-----------------------------------------------------------------------+-| Int16 | Tiny,Short |-+-------------------+-----------------------------------------------------------------------+-| Int32 | Tiny,Short,Int24,Long |-+-------------------+-----------------------------------------------------------------------+-| Int | Tiny,Short,Int24,Long,LongLong\* |-+-------------------+-----------------------------------------------------------------------+-| Int64 | Tiny,Short,Int24,Long,LongLong |-+-------------------+-----------------------------------------------------------------------+-| Integer | Tiny,Short,Int24,Long,LongLong |-+-------------------+-----------------------------------------------------------------------+-| Word8 | Tiny |-+-------------------+-----------------------------------------------------------------------+-| Word16 | Tiny,Short |-+-------------------+-----------------------------------------------------------------------+-| Word32 | Tiny,Short,Int24,Long |-+-------------------+-----------------------------------------------------------------------+-| Word64 | Tiny,Short,Int24,Long,LongLong |-| Double | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long |-+-------------------+-----------------------------------------------------------------------+-| Ratio Integer | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long,LongLong |-+-------------------+-----------------------------------------------------------------------+-| ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |-+-------------------+-----------------------------------------------------------------------+-| Lazy.ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |-+-------------------+-----------------------------------------------------------------------+-| Encoding.Text\*\* | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |-+-------------------+-----------------------------------------------------------------------+-| Lazy.Text | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |-+-------------------+-----------------------------------------------------------------------+-| [Char]/String | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |-+-------------------+-----------------------------------------------------------------------+-| UTCTime | DateTime,Timestamp |-+-------------------+-----------------------------------------------------------------------+-| Day | Year,Date,NewDate |-+-------------------+-----------------------------------------------------------------------+-| TimeOfDay | Time |-+-------------------+-----------------------------------------------------------------------+--\* When @Word@ size is 64bit--\*\* Utf8 only--Unsupported types:--+--------------------------------------------------------------------+-| Not currently supported |-+====================================================================+-| Word |-+--------------------------------------------------------------------+-| Float |-+--------------------------------------------------------------------+-| Scientific <https://github.com/yesodweb/persistent/issues/225 #225>|-+--------------------------------------------------------------------+--See <http://hackage.haskell.org/package/mysql-simple/docs/Database-MySQL-Simple-Result.html MySQL.Simple.Result>.--}-module Database.Persist.Quasi- ( parse- -- * 'PersistSettings'- , PersistSettings- , upperCaseSettings- , lowerCaseSettings- -- ** Getters and Setters- , module Database.Persist.Quasi- ) where--import Data.Text (Text)-import Database.Persist.Names-import Database.Persist.Quasi.Internal---- | 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 }+-- |+-- This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities.+--+-- The basic structure of the syntax looks like this:+--+-- > TableName+-- > fieldName FieldType+-- > otherField String+-- > nullableField Int Maybe+--+-- You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type.+--+-- @persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL:+--+-- > CREATE TABLE table_name (+-- > id SERIAL PRIMARY KEY,+-- > field_name field_type NOT NULL,+-- > other_field varchar NOT NULL,+-- > nullable_field int NULL+-- > );+--+-- Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function.+--+-- It generates a Haskell datatype with the following form:+--+-- @+-- data TableName = TableName+-- { tableNameFieldName :: FieldType+-- , tableNameOtherField :: String+-- , tableNameNullableField :: Maybe Int+-- }+-- @+--+-- As with the SQL generated, the specifics of this are customizable.+-- See the "Database.Persist.TH" module for details.+--+-- = Deriving+--+-- You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that.+-- Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses.+--+-- > User+-- > name String+-- > age Int+-- > deriving Eq Show+-- > deriving Ord+--+-- = Unique Keys+--+-- You can define a uniqueness key on a table with the following format:+--+-- > User+-- > name String+-- > age Int+-- >+-- > UniqueUserName name+--+-- This will put a unique index on the @user@ table and the @name@ field.+--+-- = Setting defaults+--+-- You can use a @default=${sql expression}@ clause to set a default for a field.+-- The thing following the @=@ is interpreted as SQL that will be put directly into the table definition.+--+-- @+-- User+-- name Text+-- admin Bool default=false+-- @+--+-- This creates a SQL definition like this:+--+-- > CREATE TABLE user (+-- > id SERIAL PRIMARY KEY,+-- > name VARCHAR NOT NULL,+-- > admin BOOL DEFAULT=false+-- > );+--+-- A restriction here is that you still need to provide a value when performing an @insert@, because the generated Haskell type has the form:+--+-- @+-- data User = User+-- { userName :: Text+-- , userAdmin :: Bool+-- }+-- @+--+-- You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default.+--+-- __Note__: Persistent determines whether or not to migrate a column's default+-- value by comparing the exact string found in your @models@ file with the one+-- returned by the database. If a database canonicalizes the SQL @FALSE@ from your+-- @models@ file to @false@ in the database, Persistent will think the default+-- value needs to be migrated and+-- <https://github.com/yesodweb/persistent/issues/241 attempt a migration each time you start your app>.+--+-- To workaround this, find the exact SQL your DBMS uses for the default value. For example, using postgres:+--+-- @+-- psql database_name # Open postgres+--+-- \\d+ table_name -- describe the table schema+-- @+--+-- @+-- ...+-- created | timestamp without time zone | not null default now()+-- @+--+-- Then use the listed default value SQL inside your @models@ file.+--+-- = Custom ID column+--+-- If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field.+-- This @User@ has a @Text@ ID.+--+-- > User+-- > Id Text+-- > name Text+-- > age Int+--+-- If you do this, it's a good idea to set a default for the ID.+-- Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts.+--+-- @+-- 'insertKey' (UserKey "Hello world!") (User "Bob" 32)+-- @+--+-- If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore.+-- So instead just use a default expression, like this:+--+-- @+-- User+-- Id Text default=generate_user_id()+-- name Text+-- age Int+-- @+--+-- = Custom Primary Keys+--+-- Sometimes you don't want to have an ID column, and you want a different sort of primary key.+-- This is a table that stores unique email addresses, and the email is the primary key.+-- We store the first and second part (eg @first\@second@) separately.+--+-- @+-- Email+-- firstPart Text+-- secondPart Text+--+-- Primary firstPart secondPart+-- @+--+-- This creates a table with the following form:+--+-- @+-- CREATE TABLE email (+-- first_part varchar,+-- second_part varchar,+--+-- PRIMARY KEY (first_part, second_part)+-- @+--+-- Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo.+-- As a key with multiple fields, it is also a "composite key."+--+-- You can specify a @Primary@ key with a single field, too.+--+-- = Overriding SQL+--+-- You can use a @sql=custom@ annotation to provide some customization on the entity and field.+-- For example, you might prefer to name a table differently than what @persistent@ will do by default.+-- You may also prefer to name a field differently.+--+-- @+-- User sql=big_user_table+-- fullName String sql=name+-- age Int+-- @+--+-- This will alter the generated SQL to be:+--+-- @+-- CREATE TABLE big_user_table (+-- id SERIAL PRIMARY KEY,+-- name VARCHAR,+-- age INT+-- );+-- @+--+-- = Customizing Types/Tables+--+-- == JSON instances+--+-- You can automatically get ToJSON and FromJSON instances for any entity by adding @json@ to the entity line:+--+-- @+-- Person json+-- name Text+-- @+-- Requires @\{\-\# LANGUAGE FlexibleInstances \#\-\}@+--+-- Customizable by using mpsEntityJSON+-- * http://hackage.haskell.org/package/persistent-template/docs/Database-Persist-TH.html#v:EntityJSON+-- * http://hackage.haskell.org/package/persistent/docs/Database-Persist-Class.html#v:keyValueEntityToJSON+--+-- == Changing table/collection name+--+-- @+-- Person sql=peoples+-- name Text+-- @+--+-- == Change table/collection key definition (field name and\/or type, persistent >= 2.1)+--+-- @Id@ defines the column to use to define the key of the entity.+-- Without type, the default backend key type will be used. You can change its+-- database name using the @sql@ attributes :+--+-- @+-- Person+-- Id sql=my_id_name+-- phone Text+-- @+--+-- With a Haskell type, the corresponding type is used. Note that you'll need to+-- use @default=@ to tell it what to do on insertion.+--+-- @+-- Person+-- Id Day default=CURRENT_DATE+-- phone Text+-- @+--+-- @default=@ works for SQL databases, and is backend specific.+-- For MongoDB currently one always needs to create the key on the application+-- side and use @insertKey@. @insert@ will not work correctly. Sql backends can+-- also do this if default does not work.+--+-- @sqltype@ can also be used to specify a different database type+--+-- @+-- Currency+-- Id String sqltype=varchar(3) sql=code+-- @+--+-- Composite key (using multiple columns) can also be defined using @Primary@.+--+-- @sql=@ also works for setting the names of unique indexes.+--+-- @+-- Person+-- name Text+-- phone Text+-- UniquePersonPhone phone sql=UniqPerPhone+-- @+--+-- This makes a unique index requiring @phone@ to be unique across @Person@ rows.+-- Ordinarily Persistent will generate a snake-case index name from the+-- capitalized name provided such that @UniquePersonPhone@ becomes+-- @unique_person_phone@. However, we provided a @sql=@ so the index name in the+-- database will instead be @UniqPerPhone@. Keep in mind @sql=@ and @!@ attrs must+-- come after the list of fields in front of the index name in the quasi-quoter.+--+--+--+-- = Customizing Fields+--+-- == Nullable Fields+--+-- As illustrated in the example at the beginning of this page, we are able to represent nullable+-- fields by including 'Maybe' at the end of the type declaration:+--+-- > TableName+-- > fieldName FieldType+-- > otherField String+-- > nullableField Int Maybe+--+-- Alternatively we can specify the keyword nullable:+--+-- > TableName+-- > fieldName FieldType+-- > otherField String+-- > nullableField Int nullable+--+-- However the difference here is in the first instance the Haskell type will be 'Maybe Int',+-- but in the second it will be 'Int'. Be aware that this will cause runtime errors if the+-- database returns @NULL@ and the @PersistField@ instance does not handle @PersistNull@.+--+-- If you wish to define your Maybe types in a way that is similar to the actual Haskell+-- definition, you can define 'Maybe Int' like so:+--+-- > TableName+-- > fieldName FieldType+-- > otherField String+-- > nullableField (Maybe Int)+--+-- However, note, the field _must_ be enclosed in parenthesis.+--+-- == @sqltype=@+--+-- By default, Persistent maps the Haskell types you specify in the Models DSL to+-- an appropriate SQL type in the database (refer to the section "Conversion table+-- (migrations)" for the default mappings). Using the+-- @sqltype=@ option, you can customize the SQL type Persistent uses for your+-- column. Use cases include:+--+-- * Interacting with an existing database whose column types don't match Persistent's defaults.+-- * Taking advantage of a specific SQL type's features+-- * e.g. Using an equivalent type that has better space or performance characteristics+--+-- To use this setting, add the @sqltype=@ option after declaring your field name and type:+--+-- @+-- User+-- username Text sqltype=varchar(255)+-- @+--+-- == Laziness+--+-- By default the records created by persistent have strict fields. You can prefix+-- a field name with @~@ to make it lazy (or @!@ to make it strict).+--+-- == Attributes+--+-- The QuasiQuoter allows you to provide arbitrary attributes to an entity or field.+-- This can be used to extend the code in ways that the library hasn't anticipated.+-- If you use this feature, we'd definitely appreciate hearing about it and+-- potentially supporting your use case directly!+--+-- @+-- User !funny+-- field String !sad+-- good Dog !sogood+-- @+--+-- We can see the attributes using the 'entityAttrs' field and the 'fieldAttrs' field.+--+-- @+-- userAttrs = do+-- let userDefinition = 'entityDef' ('Proxy' :: 'Proxy' User)+-- let userAttributes = 'entityAttrs' userDefinition+-- let fieldAttributes = 'map' 'fieldAttrs' ('entityFields' userDefinition)+-- print userAttributes+-- -- ["funny"]+-- print fieldAttributes+-- -- [["sad"],["sogood"]]+-- @+--+-- == @!no-migrate@+--+-- To prevent @migrateModels@ from generating _any_ migrations for an entity, add+-- the @!no-migrate@ attribute to it's definition:+--+-- @+-- User !no-migrate+-- field String+-- good Dog+-- @+--+-- == @MigrationOnly@+--+-- Introduced with @persistent-template@ 1.2.0. The purpose of this attribute is+-- to mark a field which will be entirely ignored by the normal processing, but+-- retained in the database definition for purposes of migration. This means, in+-- SQL, a column will not be flagged for removal by the migration scripts, even+-- though it is not used in your code. This is useful for phasing out usage of a+-- column before entirely removing it, or having columns which are needed by other+-- tools but not by Persistent.+--+-- @+-- Person+-- name Text+-- age Int+-- unusedField ByteString Maybe MigrationOnly+-- @+--+-- Note that you almost certainly want to either mark the field as @Maybe@ or+-- provide a default value, otherwise insertions will fail.+--+--+-- == @SafeToRemove@+--+-- This is intended to be used as part of a deprecation of a field, after+-- @MigrationOnly@ has been used usually. This works somewhat as a superset of the+-- functionality of @MigrationOnly@. In addition, the field will be removed from+-- the database if it is present. Note that this is a destructive change which you+-- are marking as safe.+--+-- == Constraints+--+-- Migration will remove any manual constraints from your tables. Exception: constraints whose names begin with the string @__manual_@ (which starts with two underscores) will be preserved.+--+--+-- = Foreign Keys+--+-- If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly.+--+-- @+-- Person+-- name Text+--+-- Dog+-- name Text+-- owner PersonId+-- @+--+-- This automatically creates a foreign key reference from @Dog@ to @Person@.+-- The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database.+-- If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred.+--+-- == @constraint=@+--+-- You can use the @constraint=@ attribute to override the constraint name used in+-- migrations. This is useful particularly when the automatically generated+-- constraint names exceed database limits (e.g. MySQL does not allow constraint+-- names longer than 64 characters).+--+-- @+-- VeryLongTableName+-- name Text+--+-- AnotherVeryLongTableName+-- veryLongTableNameId VeryLongTableNameId constraint=short_foreign_key+-- @+--+-- == OnUpdate and OnDelete+--+-- These options affects how a referring record behaves when the target record is changed.+-- There are several options:+--+-- * 'Restrict' - This is the default. It prevents the action from occurring.+-- * 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too.+-- * 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys.+-- * 'SetDefault' - This will set the column's value to the @default@ for the column, if specified.+--+-- To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action.+--+-- @+-- Record+-- -- If the referred Foo is deleted or updated, then this record will+-- -- also be deleted or updated.+-- fooId FooId OnDeleteCascade OnUpdateCascade+--+-- -- If the referred Bar is deleted, then we'll set the reference to+-- -- 'Nothing'. If the referred Bar is updated, then we'll cascade the+-- -- update.+-- barId BarId Maybe OnDeleteSetNull OnUpdateCascade+--+-- -- If the referred Baz is deleted, then we set to the default ID.+-- bazId BazId OnDeleteSetDefault default=1+-- @+--+-- Let's demonstrate this with a shopping cart example.+--+-- @+-- User+-- name Text+--+-- Cart+-- user UserId Maybe+--+-- CartItem+-- cartId CartId+-- itemId ItemId+--+-- Item+-- name Text+-- price Int+-- @+--+-- Let's consider how we want to handle deletions and updates.+-- If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@.+--+-- @+-- Cart+-- user UserId Maybe OnDeleteCascade OnUpdateCascade+-- @+--+-- If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database.+-- If a @Cart@ is deleted, though, then we just want to delete the @CartItem@.+--+-- @+-- CartItem+-- cartId CartId OnDeleteCascade+-- itemId ItemId OnDeleteSetDefault default=1+-- @+--+-- == @Foreign@ keyword+--+-- The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword.+--+-- A pseudo formal syntax for @Foreign@ is:+--+-- @+-- Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ]+--+-- columns := column0 [column1 column2 .. columnX]+-- references := References $(target-columns)+-- target-columns := target-column0 [target-column1 target-columns2 .. target-columnX]+-- @+--+-- Columns are the columns as defined on this entity.+-- @target-columns@ are the columns as defined on the target entity.+--+-- Let's look at some examples.+--+-- === Composite Primary Key References+--+-- The most common use for this is to refer to a composite primary key.+-- Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column.+--+-- @+-- Email+-- firstPart Text+-- secondPart Text+-- Primary firstPart secondPart+--+-- User+-- name Text+-- emailFirstPart Text+-- emailSecondPart Text+--+-- Foreign Email fk_user_email emailFirstPart emailSecondPart+-- @+--+-- If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key.+-- If we wanted to be fully redundant, we could specify the @References@ keyword.+--+-- @+-- Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart+-- @+--+-- We can specify delete/cascade behavior directly after the target table.+--+-- @+-- Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart+-- @+--+-- Now, if the email is deleted or updated, the user will be deleted or updated to match.+--+-- === Non-Primary Key References+--+-- SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint.+-- Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent.+-- To do this, we must use the @References@ keyword.+--+-- @+-- User+-- name Text+-- email Text+--+-- UniqueEmail email+--+-- Notification+-- content Text+-- sentTo Text+--+-- Foreign User fk_noti_user sentTo References email+-- @+--+-- If the target uniqueness constraint has multiple columns, then you must specify them independently.+--+-- @+-- User+-- name Text+-- emailFirst Text+-- emailSecond Text+--+-- UniqueEmail emailFirst emailSecond+--+-- Notification+-- content Text+-- sentToFirst Text+-- sentToSecond Text+--+-- Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond+-- @+--+-- = Documentation Comments+--+-- The quasiquoter supports ordinary comments with @--@ and @#@.+-- Since @persistent-2.10.5.1@, it also supports documentation comments.+-- The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions:+--+-- 1. Only the @-- | @ form is allowed.+-- 2. You must put a space before and after the @|@ pipe character.+-- 3. The comment must be indented at the same level as the entity or field it documents.+--+-- An example of the field documentation is:+--+-- @+-- -- | I am a doc comment for a User. Users are important+-- -- | to the application, and should be treasured.+-- User+-- -- | Users have names. Call them by names.+-- name String+-- -- | A user can be old, or young, and we care about+-- -- | this for some reason.+-- age Int+-- @+--+-- The documentation is present on the @entityComments@ field on the @EntityDef@ for the entity:+--+-- @+-- >>> let userDefinition = entityDef (Proxy :: Proxy User)+-- >>> entityComments userDefinition+-- "I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n"+-- @+--+-- Likewise, the field documentation is present in the @fieldComments@ field on the @FieldDef@ present in the @EntityDef@:+--+-- @+-- >>> let userFields = entityFields userDefinition+-- >>> let comments = map fieldComments userFields+-- >>> mapM_ putStrLn comments+-- "Users have names. Call them by names."+-- "A user can be old, or young, and we care about\nthis for some reason."+-- @+--+-- Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False).+-- @persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.+--+-- = Sum types+--+-- == Field level+--+-- You'll frequently want to store an enum of values in your database. For+-- example, you might describe a @Person@'s employment status as being @Employed@,+-- @Unemployed@, or @Retired@. In Haskell this is represented with a sum type, and+-- Persistent provides a Template Haskell function to marshall these values to and+-- from the database:+--+-- @+-- -- @Employment.hs+-- {-# LANGUAGE TemplateHaskell #-}+-- module Employment where+--+-- import Database.Persist.TH+-- import Prelude+--+-- data Employment = Employed | Unemployed | Retired+-- deriving (Show, Read, Eq)+-- derivePersistField "Employment"+-- @+--+-- @derivePersistField@ stores sum type values as strins in the database. While not as efficient as using integers, this approach simplifies adding and removing values from your enumeration.+--+-- Due to the GHC Stage Restriction, the call to the Template Haskell function @derivePersistField@ must be in a separate module than where the generated code is used.+--+-- Note: If you created a new module, make sure add it to the @exposed-modules@ section of your Cabal file.+--+-- Use the module by importing it into your @Model.hs@ file:+--+-- @+-- -- @Model.hs+-- import Employment+-- @+--+-- and use it in the @models@ DSL:+--+-- @+-- Person+-- employment Employment+-- @+--+-- You can export the Employment module from Import to use it across your app:+--+-- @+-- -- @Import.hs+-- import Employment as Import+-- @+--+-- === Entity-level+--+-- NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints).+--+-- The+-- <https://github.com/yesodweb/persistent/blob/master/persistent-test/src/SumTypeTest.hs#L35 tests for this feature>+-- demonstrate their usage. Note the use of the sign @+@ in front of the entity+-- name.+--+-- The schema in the test is reproduced here:+--+-- @+-- share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase|+-- Bicycle+-- brand T.Text+-- Car+-- make T.Text+-- model T.Text+-- +Vehicle+-- bicycle BicycleId+-- car CarId+-- |]+-- @+--+-- Let's check out the definition of the Haskell type @Vehicle@.+-- Using @ghci@, we can query for @:info Vehicle@:+--+-- >>> :i Vehicle+-- type Vehicle = VehicleGeneric SqlBackend+-- -- Defined at .../Projects/persistent/persistent-test/src/SumTypeTest.hs:26:1+--+-- >>> :i VehicleGeneric+-- type role VehicleGeneric nominal+-- data VehicleGeneric backend+-- = VehicleBicycleSum (Key (BicycleGeneric backend))+-- | VehicleCarSum (Key (CarGeneric backend))+-- -- Defined at .../persistent/persistent-test/src/SumTypeTest.hs:26:1+-- -- lots of instances follow...+--+-- A @VehicleGeneric@ has two constructors:+--+-- - @VehicleBicycleSum@ with a @Key (BicycleGeneric backend)@ field+-- - @VehicleCarSum@ with a @Key (CarGeneric backend)@ field+--+-- The @Bicycle@ and @Car@ are typical @persistent@ entities.+--+-- This generates the following SQL migrations (formatted for readability):+--+-- @+-- CREATE TABLE "bicycle" (+-- "id" INTEGER PRIMARY KEY,+-- "brand" VARCHAR NOT NULL+-- );+--+-- CREATE TABLE "car"(+-- "id" INTEGER PRIMARY KEY,+-- "make" VARCHAR NOT NULL,+-- "model" VARCHAR NOT NULL+-- );+--+-- CREATE TABLE "vehicle"(+-- "id" INTEGER PRIMARY KEY,+-- "bicycle" INTEGER NULL REFERENCES "bicycle",+-- "car" INTEGER NULL REFERENCES "car"+-- );+-- @+--+-- The @vehicle@ table contains a nullable foreign key reference to both the bicycle and the car tables.+--+-- A SQL query that grabs all the vehicles from the database looks like this (note the @??@ is for the @persistent@ raw SQL query functions):+--+-- @+-- SELECT ??, ??, ??+-- FROM vehicle+-- LEFT JOIN car+-- ON vehicle.car = car.id+-- LEFT JOIN bicycle+-- ON vehicle.bicycle = bicycle.id+-- @+--+-- If we use the above query with @rawSql@, we'd get the following result:+--+-- @+-- getVehicles+-- :: SqlPersistM+-- [ ( Entity Vehicle+-- , Maybe (Entity Bicycle)+-- , Maybe (Entity Car)+-- )+-- ]+-- @+--+-- This result has some post-conditions that are not guaranteed by the types *or* the schema.+-- The constructor for @Entity Vehicle@ is going to determine which of the other members of the tuple is @Nothing@.+-- We can convert this to a friendlier domain model like this:+--+-- @+-- data Vehicle'+-- = Car' Text Text+-- | Bike Text+--+-- check = do+-- result <- getVehicles+-- pure (map convert result)+--+-- convert+-- :: (Entity Vehicle, Maybe (Entity Bicycle), Maybe (Entity Car))+-- -> Vehicle'+-- convert (Entity _ (VehicleBicycleSum _), Just (Entity _ (Bicycle brand)), _) =+-- Bike brand+-- convert (Entity _ (VehicleCarSum _), _, Just (Entity _ (Car make model))) =+-- Car make model+-- convert _ =+-- error "The database preconditions have been violated!"+-- @+--+-- == Times with timezones+--+-- Storing times with timezones in one type in databases is not possible, although+-- it seems that it should be possible (@timezone@ and @timezonetz@ in+-- PostgreSQL). That's why starting with persistent 2.0, all times will be mapped+-- to @UTCTime@. If you need to store timezone information along with times in a+-- database, store the timezone in a second field. Here are some links about the+-- topic with further information:+--+-- * https://github.com/yesodweb/persistent/issues/290+-- * https://groups.google.com/forum/#!msg/yesodweb/MIfcV2bwM80/8QLFpgp1LykJ+-- * http://stackoverflow.com/questions/14615271/postgres-timestamp/14616640#14616640+-- * http://justatheory.com/computers/databases/postgresql/use-timestamptz.html+-- * https://github.com/lpsmith/postgresql-simple/issues/69+-- * https://github.com/nikita-volkov/hasql-postgres/issues/1+--+-- = Conversion table (migrations)+--+-- Here are the conversions between Haskell types and database types:+--+-- +------------+----------------------+-------------------+---------------+----------------++-- | Haskell | PostgreSQL | MySQL | MongoDB | SQLite |+-- +============+======================+===================+===============+================++-- | Text | VARCHAR | TEXT | String | VARCHAR |+-- +------------+----------------------+-------------------+---------------+----------------++-- | ByteString | BYTEA | BLOB | BinData | BLOB |+-- +------------+----------------------+-------------------+---------------+----------------++-- | Int | INT8 | BIGINT(20) | NumberLong | INTEGER |+-- +------------+----------------------+-------------------+---------------+----------------++-- | Double | DOUBLE PRECISION | DOUBLE | Double | REAL |+-- +------------+----------------------+-------------------+---------------+----------------++-- | Rational | NUMERIC(22, 12) | DECIMAL(32,20) | *Unsupported* | NUMERIC(32,20)|+-- +------------+----------------------+-------------------+---------------+----------------++-- | Bool | BOOLEAN | TINYINT(1) | Boolean | BOOLEAN |+-- +------------+----------------------+-------------------+---------------+----------------++-- | Day | DATE | DATE | NumberLong | DATE |+-- +------------+----------------------+-------------------+---------------+----------------++-- | TimeOfDay | TIME | TIME\*\* | *Unsupported* | TIME |+-- +------------+----------------------+-------------------+---------------+----------------++-- | UTCTime\* | TIMESTAMP | DATETIME\*\* | Date | TIMESTAMP |+-- +------------+----------------------+-------------------+---------------+----------------++--+-- Notes:+--+-- \* Support for @ZonedTime@ was dropped in persistent 2.0. @UTCTime@ can be used+-- with @timestamp without timezone@ and @timestamp with timezone@ in PostgreSQL.+-- See also the section "Times with timezones".+--+-- \*\* The default resolution for @TIME@ and @DATETIME@ in MySQL is one second.+-- As of MySQL version 5.6.4, and persistent-mysql-2.6.2, fractional seconds are+-- handled correctly if you declare an explicit precision by using @sqltype@. For+-- example, appending @sqltype=TIME(6)@ to a @TimeOfDay@ field definition will+-- give microsecond resolution.+--+-- = Compatibility tables+--+-- MySQL:+--+-- +-------------------+-----------------------------------------------------------------------++-- |Haskell type | Compatible MySQL types |+-- +===================+=======================================================================++-- | Bool | Tiny |+-- +-------------------+-----------------------------------------------------------------------++-- | Int8 | Tiny |+-- +-------------------+-----------------------------------------------------------------------++-- | Int16 | Tiny,Short |+-- +-------------------+-----------------------------------------------------------------------++-- | Int32 | Tiny,Short,Int24,Long |+-- +-------------------+-----------------------------------------------------------------------++-- | Int | Tiny,Short,Int24,Long,LongLong\* |+-- +-------------------+-----------------------------------------------------------------------++-- | Int64 | Tiny,Short,Int24,Long,LongLong |+-- +-------------------+-----------------------------------------------------------------------++-- | Integer | Tiny,Short,Int24,Long,LongLong |+-- +-------------------+-----------------------------------------------------------------------++-- | Word8 | Tiny |+-- +-------------------+-----------------------------------------------------------------------++-- | Word16 | Tiny,Short |+-- +-------------------+-----------------------------------------------------------------------++-- | Word32 | Tiny,Short,Int24,Long |+-- +-------------------+-----------------------------------------------------------------------++-- | Word64 | Tiny,Short,Int24,Long,LongLong |+-- | Double | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long |+-- +-------------------+-----------------------------------------------------------------------++-- | Ratio Integer | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long,LongLong |+-- +-------------------+-----------------------------------------------------------------------++-- | ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |+-- +-------------------+-----------------------------------------------------------------------++-- | Lazy.ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |+-- +-------------------+-----------------------------------------------------------------------++-- | Encoding.Text\*\* | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |+-- +-------------------+-----------------------------------------------------------------------++-- | Lazy.Text | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |+-- +-------------------+-----------------------------------------------------------------------++-- | [Char]/String | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum |+-- +-------------------+-----------------------------------------------------------------------++-- | UTCTime | DateTime,Timestamp |+-- +-------------------+-----------------------------------------------------------------------++-- | Day | Year,Date,NewDate |+-- +-------------------+-----------------------------------------------------------------------++-- | TimeOfDay | Time |+-- +-------------------+-----------------------------------------------------------------------++--+-- \* When @Word@ size is 64bit+--+-- \*\* Utf8 only+--+-- Unsupported types:+--+-- +--------------------------------------------------------------------++-- | Not currently supported |+-- +====================================================================++-- | Word |+-- +--------------------------------------------------------------------++-- | Float |+-- +--------------------------------------------------------------------++-- | Scientific <https://github.com/yesodweb/persistent/issues/225 #225>|+-- +--------------------------------------------------------------------++--+-- See <http://hackage.haskell.org/package/mysql-simple/docs/Database-MySQL-Simple-Result.html MySQL.Simple.Result>.+module Database.Persist.Quasi+ ( parse++ -- * 'PersistSettings'+ , PersistSettings+ , upperCaseSettings+ , lowerCaseSettings++ -- ** Getters and Setters+ , getPsToDBName+ , setPsToDBName+ , setPsToFKName+ , setPsUseSnakeCaseForeignKeys+ , setPsUseSnakeCaseForiegnKeys+ , getPsStrictFields+ , setPsStrictFields+ , getPsIdName+ , setPsIdName+ , getPsTabErrorLevel+ , setPsTabErrorLevel+ , getPsQuotedArgumentErrorLevel+ , setPsQuotedArgumentErrorLevel+ ) where++import Database.Persist.Quasi.Internal+import Database.Persist.Quasi.PersistSettings
Database/Persist/Quasi/Internal.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}@@ -18,58 +16,65 @@ , PersistSettings (..) , upperCaseSettings , lowerCaseSettings- , toFKNameInfixed- , Token (..)- , Line (..)- , preparse- , parseLine+ , Attribute (..)+ , SourceLoc (..)+ , sourceLocFromTHLoc , parseFieldType- , associateLines- , LinesWithComments(..)- , parseEntityFields , takeColsEx- -- * UnboundEntityDef- , UnboundEntityDef(..)+ , CumulativeParseResult+ , renderErrors+ , parserWarningMessage++ -- * UnboundEntityDef+ , UnboundEntityDef (..) , getUnboundEntityNameHS , unbindEntityDef , getUnboundFieldDefs- , UnboundForeignDef(..)+ , UnboundForeignDef (..) , getSqlNameOr- , UnboundFieldDef(..)- , UnboundCompositeDef(..)- , UnboundIdDef(..)+ , UnboundFieldDef (..)+ , UnboundCompositeDef (..)+ , UnboundIdDef (..) , unbindFieldDef , isUnboundFieldNullable , unboundIdDefToFieldDef- , PrimarySpec(..)+ , PrimarySpec (..) , mkAutoIdField'- , UnboundForeignFieldList(..)- , ForeignFieldReference(..)+ , UnboundForeignFieldList (..)+ , ForeignFieldReference (..) , mkKeyConType , isHaskellUnboundField- , FieldTypeLit(..)+ , FieldTypeLit (..) ) where import Prelude hiding (lines) -import Control.Applicative (Alternative((<|>)))+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 Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL-import qualified Data.Map as M 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)+import Language.Haskell.TH.Syntax (Lift, Loc (..)) import qualified Text.Read as R -data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show+data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving (Show) parseFieldType :: Text -> Either String FieldType parseFieldType t0 =@@ -82,19 +87,22 @@ parseApplyFT :: Text -> ParseState FieldType parseApplyFT t = case goMany id t of- PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'+ 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+ :: 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+ 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@@ -102,11 +110,11 @@ Nothing -> pure PSDone Just (x, xs) -> parseSpace x xs- <|> parseParenEnclosed x xs- <|> parseList x xs- <|> parseNumericLit x xs- <|> parseTextLit x xs- <|> parseTypeCon 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@@ -124,26 +132,29 @@ parseTextLit :: Char -> Text -> Maybe (ParseState FieldType) parseTextLit c t = do guard (c == '"')- let (a, b) = T.break (== '"') t+ 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+ 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+ 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'+ PSSuccess x t' -> goMany (front . (x :)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t @@ -157,270 +168,79 @@ '\'' -> 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--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- -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax>- --- -- @since 2.0- }--defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings-defaultPersistSettings = PersistSettings- { psToDBName = id- , psToFKName = \(EntityNameHS entName) (ConstraintNameHS conName) -> entName <> conName- , 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- }+ 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 -toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text-toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) =- entName <> inf <> conName+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 -> Text -> [UnboundEntityDef]-parse ps = maybe [] (parseLines ps) . preparse--preparse :: Text -> Maybe (NonEmpty Line)-preparse txt = do- lns <- NEL.nonEmpty (T.lines txt)- NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns)--parseLine :: Text -> Maybe Line-parseLine txt = do- Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt)---- | A token used by the parser.-data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted.- | DocComment Text -- ^ @DocComment@ is a documentation comment, unmodified.- deriving (Show, Eq)--tokenText :: Token -> Text-tokenText tok =- case tok of- Token t -> t- DocComment t -> "-- | " <> t--parseIndentationAmount :: Text -> Int-parseIndentationAmount txt =- let (spaces, _) = T.span isSpace txt- in T.length spaces---- | Tokenize a string.-tokenize :: Text -> [Token]-tokenize t- | T.null t = []- | Just txt <- T.stripPrefix "-- |" t = [DocComment (T.stripStart txt)]- | "--" `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) =- tokenize (T.dropWhile isSpace t)-- -- 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+parse+ :: PersistSettings+ -> [(Maybe SourceLoc, Text)]+ -> CumulativeParseResult [UnboundEntityDef]+parse ps chunks = toCumulativeParseResult $ map parseChunk chunks where- findMidToken :: Text -> Maybe (Text, Text)- findMidToken t' =- case T.break (== '=') t' of- (x, T.drop 1 -> y)- | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y)- _ -> Nothing-- quotes :: Text -> ([Text] -> [Text]) -> [Token]- 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 :: Int -> Text -> ([Text] -> [Text]) -> [Token]- 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 line of parsed tokens-data Line = Line- { lineIndent :: Int- , tokens :: NonEmpty Token- } deriving (Eq, Show)--lineText :: Line -> NonEmpty Text-lineText = fmap tokenText . tokens--lowestIndent :: NonEmpty Line -> Int-lowestIndent = minimum . fmap lineIndent---- | Divide lines into blocks and make entity definitions.-parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef]-parseLines ps = do- fmap (mkUnboundEntityDef ps . toParsedEntityDef) . associateLines--data ParsedEntityDef = ParsedEntityDef- { parsedEntityDefComments :: [Text]- , parsedEntityDefEntityName :: EntityNameHS- , parsedEntityDefIsSum :: Bool- , parsedEntityDefEntityAttributes :: [Attr]- , parsedEntityDefFieldAttributes :: [[Token]]- , parsedEntityDefExtras :: M.Map Text [ExtraLine]- }+ parseChunk :: (Maybe SourceLoc, Text) -> ParseResult [UnboundEntityDef]+ parseChunk (mSourceLoc, source) =+ (fmap . fmap) (mkUnboundEntityDef ps) <$> parseSource ps mSourceLoc source -entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB)+entityNamesFromParsedDef+ :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) where entNameHS = parsedEntityDefEntityName parsedEntDef entNameDB =- EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef)+ EntityNameDB $+ getDbName+ ps+ (unEntityNameHS entNameHS)+ (attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef) -toParsedEntityDef :: LinesWithComments -> ParsedEntityDef-toParsedEntityDef lwc = ParsedEntityDef- { parsedEntityDefComments = lwcComments lwc- , parsedEntityDefEntityName = entNameHS- , parsedEntityDefIsSum = isSum- , parsedEntityDefEntityAttributes = entAttribs- , parsedEntityDefFieldAttributes = attribs- , parsedEntityDefExtras = extras+-- | 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 }- where- entityLine :| fieldLines =- lwcLines lwc-- (entityName :| entAttribs) =- lineText entityLine-- (isSum, entNameHS) =- case T.uncons entityName of- Just ('+', x) -> (True, EntityNameHS x)- _ -> (False, EntityNameHS entityName)-- (attribs, extras) =- parseEntityFields fieldLines--isDocComment :: Token -> Maybe Text-isDocComment tok =- case tok of- DocComment txt -> Just txt- _ -> Nothing--data LinesWithComments = LinesWithComments- { lwcLines :: NonEmpty Line- , lwcComments :: [Text]- } deriving (Eq, Show)--instance Semigroup LinesWithComments where- a <> b =- LinesWithComments- { lwcLines =- foldr NEL.cons (lwcLines b) (lwcLines a)- , lwcComments =- lwcComments a `mappend` lwcComments b- }--appendLwc :: LinesWithComments -> LinesWithComments -> LinesWithComments-appendLwc = (<>)--newLine :: Line -> LinesWithComments-newLine l = LinesWithComments (pure l) []--firstLine :: LinesWithComments -> Line-firstLine = NEL.head . lwcLines--consLine :: Line -> 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 :: NonEmpty Line -> [LinesWithComments]-associateLines lines =- foldr combine [] $- foldr toLinesWithComments [] lines- where- toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments]- toLinesWithComments line linesWithComments =- case linesWithComments of- [] ->- [newLine line]- (lwc : lwcs) ->- case isDocComment (NEL.head (tokens line)) of- Just comment- | lineIndent line == lowestIndent lines ->- consComment comment lwc : lwcs- _ ->- if lineIndent line <= lineIndent (firstLine lwc)- && lineIndent (firstLine lwc) /= lowestIndent lines- then- consLine line lwc : lwcs- else- newLine line : lwc : lwcs-- 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 :: LinesWithComments -> Int- minimumIndentOf = lowestIndent . lwcLines+ 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@@ -458,6 +278,10 @@ -- 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) @@ -481,6 +305,7 @@ ed , unboundEntityFields = map unbindFieldDef (entityFields ed)+ , unboundEntityDefSpan = entitySpan ed } -- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns@@ -587,24 +412,25 @@ -- -- @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- }+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 =@@ -619,55 +445,56 @@ -- -- @since 2.13.0.0 data PrimarySpec- = NaturalKey UnboundCompositeDef- -- ^ 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- | SurrogateKey UnboundIdDef- -- ^ 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- | DefaultKey FieldNameDB- -- ^ 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+ = -- | 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+ -> ParsedEntityDef+ -- ^ parsed entity definition -> UnboundEntityDef mkUnboundEntityDef ps parsedEntDef = UnboundEntityDef@@ -675,58 +502,66 @@ entityConstraintDefsForeignsList entityConstraintDefs , unboundPrimarySpec = case (idField, primaryComposite) of- (Just {}, Just {}) ->+ (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+ 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 =+ , -- 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+ maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField , entityAttrs =- parsedEntityDefEntityAttributes parsedEntDef- , entityFields =- []+ attributeContent <$> parsedEntityDefEntityAttributes parsedEntDef+ , entityFields = [] , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs , entityForeigns = []- , entityDerives = concat $ mapMaybe takeDerives textAttribs+ , entityDerives = concat $ mapMaybe takeDerives (textFields ++ textDirectives) , entityExtra = parsedEntityDefExtras parsedEntDef , entitySum = parsedEntityDefIsSum parsedEntDef , entityComments = case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments)+ , entitySpan = parsedEntityDefSpan parsedEntDef } } where (entNameHS, entNameDB) = entityNamesFromParsedDef ps parsedEntDef - attribs =- parsedEntityDefFieldAttributes parsedEntDef+ fields = parsedEntityDefFields parsedEntDef+ directives = parsedEntityDefDirectives parsedEntDef - textAttribs :: [[Text]]- textAttribs =- fmap tokenText <$> attribs+ 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) textAttribs+ foldMap+ (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty)+ (textFields ++ textDirectives) idField = case entityConstraintDefsIdField entityConstraintDefs of@@ -740,8 +575,13 @@ SetOnce a -> Just a NotSet -> Nothing - cols :: [UnboundFieldDef]- cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs+ commentedField+ :: PersistSettings+ -> (EntityField, Maybe Text)+ -> Maybe UnboundFieldDef+ commentedField s (field, mCommentText) = do+ unb <- takeColsEx s (entityFieldContent field)+ pure $ unb{unboundFieldComments = mCommentText} autoIdField :: FieldDef autoIdField =@@ -818,35 +658,10 @@ Just $ fieldType fd } -associateComments- :: PersistSettings- -> [Token]- -> ([UnboundFieldDef], [Text])- -> ([UnboundFieldDef], [Text])-associateComments ps x (!acc, !comments) =- case listToMaybe x of- Just (DocComment comment) ->- (acc, comment : comments)- _ ->- case (setFieldComments (reverse comments) <$> takeColsEx ps (tokenText <$> x)) of- Just sm ->- (sm : acc, [])- Nothing ->- (acc, [])--setFieldComments :: [Text] -> UnboundFieldDef -> UnboundFieldDef-setFieldComments xs fld =- case xs of- [] -> fld- _ -> fld { unboundFieldComments = Just (T.unlines xs) }- mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef mkAutoIdField ps = mkAutoIdField' (FieldNameDB $ psIdName ps) --- | Creates a default ID field.------ @since 2.13.0.0 mkAutoIdField' :: FieldNameDB -> EntityNameHS -> SqlType -> FieldDef mkAutoIdField' dbName entName idSqlType = FieldDef@@ -854,8 +669,7 @@ , fieldDB = dbName , fieldType = FTTypeCon Nothing $ keyConName entName , fieldSqlType = idSqlType- , fieldReference =- NoReference+ , fieldReference = NoReference , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing@@ -867,23 +681,6 @@ keyConName :: EntityNameHS -> Text keyConName entName = unEntityNameHS entName `mappend` "Id" -parseEntityFields- :: [Line]- -> ([[Token]], M.Map Text [ExtraLine])-parseEntityFields lns =- case lns of- [] -> ([], M.empty)- (line : rest) ->- case NEL.toList (tokens line) of- [Token name]- | isCapitalizedText name ->- let (children, rest') = span ((> lineIndent line) . lineIndent) rest- (x, y) = parseEntityFields rest'- in (x, M.insert name (NEL.toList . lineText <$> children) y)- ts ->- let (x, y) = parseEntityFields rest- in (ts:x, y)- isCapitalizedText :: Text -> Bool isCapitalizedText t = not (T.null t) && isUpper (T.head t)@@ -898,29 +695,31 @@ -> PersistSettings -> [Text] -> Maybe UnboundFieldDef-takeCols _ _ ("deriving":_) = Nothing-takeCols onErr ps (n':typ:rest')+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_- }+ 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_@@ -929,7 +728,6 @@ | 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@@ -960,9 +758,9 @@ Nothing data SetOnceAtMost a- = NotSet- | SetOnce a- | SetMoreThanOnce+ = NotSet+ | SetOnce a+ | SetMoreThanOnce instance Semigroup (SetOnceAtMost a) where a <> b =@@ -986,10 +784,14 @@ 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+ { entityConstraintDefsIdField =+ entityConstraintDefsIdField a <> entityConstraintDefsIdField b+ , entityConstraintDefsPrimaryComposite =+ entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b+ , entityConstraintDefsUniques =+ entityConstraintDefsUniques a <> entityConstraintDefsUniques b+ , entityConstraintDefsForeigns =+ entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b } instance Monoid EntityConstraintDefs where@@ -1024,7 +826,7 @@ let unboundComposite = takeComposite (unboundFieldNameHS <$> defs) rest- in+ in mempty { entityConstraintDefsPrimaryComposite = SetOnce unboundComposite@@ -1036,47 +838,15 @@ { entityConstraintDefsIdField = SetOnce (takeId ps entityName rest) }- _ | isCapitalizedText n ->- mempty- { entityConstraintDefsUniques =- pure <$> takeUniq ps "" defs (n : rest)- }+ _+ | isCapitalizedText n ->+ mempty+ { entityConstraintDefsUniques =+ pure <$> takeUniq ps "" defs (n : rest)+ } _ -> mempty --- | 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)- -- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName. -- need to re-work takeCols function takeId :: PersistSettings -> EntityNameHS -> [Text] -> UnboundIdDef@@ -1122,8 +892,9 @@ } deriving (Eq, Ord, Show, Lift) -compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef-compositeToUniqueDef entityName fields UnboundCompositeDef {..} =+compositeToUniqueDef+ :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef+compositeToUniqueDef entityName fields UnboundCompositeDef{..} = UniqueDef { uniqueHaskell = ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey")@@ -1141,12 +912,10 @@ error "Unable to find `hsName` in fields" (a : _) -> a- matchHsName hsName UnboundFieldDef {..} = do+ matchHsName hsName UnboundFieldDef{..} = do guard $ unboundFieldNameHS == hsName pure unboundFieldNameDB -- takeComposite :: [FieldNameHS] -> [Text]@@ -1167,7 +936,7 @@ xs (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t- getDef (d:ds) t+ getDef (d : ds) t | d == FieldNameHS t = -- TODO: check for nullability in later step -- if nullable (fieldAttrs d) /= NotNullable@@ -1189,23 +958,24 @@ 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- }+ pure+ UniqueDef+ { uniqueHaskell =+ ConstraintNameHS n+ , uniqueDBName =+ dbName+ , uniqueFields =+ fmap (\a -> (FieldNameHS a, getDBName defs a)) fields+ , uniqueAttrs =+ attrs+ } where isAttr a =- "!" `T.isPrefixOf` a+ "!" `T.isPrefixOf` a isSqlName a =- "sql=" `T.isPrefixOf` a+ "sql=" `T.isPrefixOf` a isNonField a =- isAttr a || isSqlName a+ isAttr a || isSqlName a (fieldsList, nonFields) = break isNonField rest mfields =@@ -1214,39 +984,44 @@ attrs = filter isAttr nonFields usualDbName =- ConstraintNameDB $ psToDBName ps (tableName `T.append` n)+ 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+ 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+ 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+ 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)+ "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. --@@ -1283,38 +1058,38 @@ -- | A list of fields present on the foreign reference. data UnboundForeignFieldList- = FieldListImpliedId (NonEmpty FieldNameHS)- -- ^ 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- | FieldListHasReferences (NonEmpty ForeignFieldReference)- -- ^ 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+ = -- | 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+data ForeignFieldReference+ = ForeignFieldReference { ffrSourceField :: FieldNameHS -- ^ The column on the source table. --@@ -1335,7 +1110,7 @@ fd } where- mk ((fH, _), (pH, _)) =+ mk ((fH, _), (pH, _)) = ForeignFieldReference { ffrSourceField = fH , ffrTargetField = pH@@ -1355,12 +1130,12 @@ 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+ then+ Left "Target and source length differe on foreign reference."+ else+ Right $+ FieldListHasReferences $+ NEL.zipWith ForeignFieldReference sources targets takeForeign :: PersistSettings@@ -1370,16 +1145,19 @@ takeForeign ps entityName = takeRefTable where errorPrefix :: String- errorPrefix = "invalid foreign key constraint on table[" ++ show (unEntityNameHS entityName) ++ "] "+ errorPrefix =+ "invalid foreign key constraint on table["+ ++ show (unEntityNameHS entityName)+ ++ "] " takeRefTable :: [Text] -> UnboundForeignDef takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name"- takeRefTable (refTableName:restLine) =+ takeRefTable (refTableName : restLine) = go restLine Nothing Nothing where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef- go (constraintNameText:rest) onDelete onUpdate+ go (constraintNameText : rest) onDelete onUpdate | not (T.null constraintNameText) && isLower (T.head constraintNameText) = UnboundForeignDef { unboundForeignFields =@@ -1425,32 +1203,37 @@ | flen == plen -> (ffs, pfs) (flen, plen) ->- error $ errorPrefix ++ concat- [ "Found " , show flen- , " foreign fields but "- , show plen, " parent fields"- ]-+ 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+ go xs _ _ =+ error $+ errorPrefix+ ++ "expecting a lower case constraint name or a cascading action xs="+ ++ show xs -toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB+toFKConstraintNameDB+ :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName)- data CascadePrefix = CascadeUpdate | CascadeDelete parseCascade :: [Text] -> (FieldCascade, [Text])@@ -1501,7 +1284,7 @@ CascadeDelete -> "Delete" takeDerives :: [Text] -> Maybe [Text]-takeDerives ("deriving":rest) = Just rest+takeDerives ("deriving" : rest) = Just rest takeDerives _ = Nothing -- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or@@ -1510,8 +1293,8 @@ -- @since 2.13.0.0 isHaskellUnboundField :: UnboundFieldDef -> Bool isHaskellUnboundField fd =- FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd &&- FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd+ FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd+ && FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd -- | Return the 'EntityNameHS' for an 'UnboundEntityDef'. --@@ -1519,5 +1302,5 @@ getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS getUnboundEntityNameHS = entityHaskell . unboundEntityDef -readMaybe :: Read a => Text -> Maybe a+readMaybe :: (Read a) => Text -> Maybe a readMaybe = R.readMaybe . T.unpack
+ Database/Persist/Quasi/Internal/ModelParser.hs view
@@ -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
+ Database/Persist/Quasi/Internal/TypeParser.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Persist.Quasi.Internal.TypeParser+ ( TypeExpr (..)+ , TypeConstructor (..)+ , typeExpr+ , innerTypeExpr+ , typeExprContent+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as L++-- | A parsed type expression.+--+-- @since 2.17.1.0+data TypeExpr+ = TypeApplication TypeExpr [TypeExpr]+ | TypeConstructorExpr TypeConstructor+ | TypeLitString String+ | TypeLitInt String+ | TypeLitPromotedConstructor TypeConstructor+ deriving (Show, Eq)++-- | A parsed type constructor.+--+-- @since 2.17.1.0+data TypeConstructor+ = ListConstructor+ | TypeConstructor String+ deriving (Show, Eq)++-- | Parses a Persistent-style type expression.+-- Persistent's type expressions are largely similar to Haskell's, but with a few differences:+--+-- 1. Syntactic sugar is not currently supported for constructing types other than List.+-- 2. Only certain typelevel literals are supported: Strings, Ints, and promoted type constructors.+-- 3. Because they must be parsed as part of an entity field definition, top-level applications+-- of non-nullary type constructors (except for the sugary List constructor) must+-- be parenthesized.+--+-- VALID: Int+-- VALID: [Maybe Int]+-- VALID: (Maybe Int)+-- INVALID: Maybe Int+--+-- @since 2.17.1.0+typeExpr :: ((MonadParsec e String) m) => m TypeExpr+typeExpr = typeExpr' Outer++-- | Parses a type expression in non-top-level contexts, where an unparenthesized type constructor+-- application is acceptable.+--+-- @since 2.17.1.0+innerTypeExpr :: ((MonadParsec e String) m) => m TypeExpr+innerTypeExpr = typeExpr' Inner++data IsInner = Inner | Outer++typeExpr' :: ((MonadParsec e String) m) => IsInner -> m TypeExpr+typeExpr' isInner = label "type expression" $ do+ let+ validEmbeddedApplications = case isInner of+ Inner ->+ [ simpleTypeApplication+ , complexTypeApplication+ ]+ Outer -> [nullaryTypeApplication]+ choice $+ validEmbeddedApplications+ ++ [ whitespaceBetween '(' ')' innerTypeExpr+ , listType+ , typeLitPromotedConstructor+ , typeLitString+ , typeLitInt+ ]+ where+ -- This is a proper subset of `simpleTypeApplication`.+ nullaryTypeApplication :: ((MonadParsec e String) m) => m TypeExpr+ nullaryTypeApplication = do+ tc <- typeConstructor <* optional hspace+ pure $ TypeApplication (TypeConstructorExpr tc) []++-- This does not parse sugary constructors such as the List constructor `[]`.+typeConstructor :: ((MonadParsec e String) m) => m TypeConstructor+typeConstructor = do+ first <- upperChar+ rest <- many $ choice [alphaNumChar, char '.', char '\'']+ pure $ TypeConstructor (first : rest)++whitespaceBetween :: ((MonadParsec e String) m) => Char -> Char -> m a -> m a+whitespaceBetween ldelim rdelim =+ between (char ldelim *> optional hspace) (optional hspace *> char rdelim)++complexTypeApplication :: ((MonadParsec e String) m) => m TypeExpr+complexTypeApplication = do+ t <- whitespaceBetween '(' ')' innerTypeExpr <* hspace+ args <- some (typeExpr <* optional hspace)+ pure $ TypeApplication t args++simpleTypeApplication :: ((MonadParsec e String) m) => m TypeExpr+simpleTypeApplication = do+ tc <- typeConstructor <* optional hspace+ args <- many (typeExpr <* optional hspace)+ pure $ TypeApplication (TypeConstructorExpr tc) args++typeLitString :: ((MonadParsec e String) m) => m TypeExpr+typeLitString = do+ s <- char '"' *> manyTill L.charLiteral (char '"')+ pure $ TypeLitString s++typeLitInt :: ((MonadParsec e String) m) => m TypeExpr+typeLitInt = TypeLitInt <$> some digitChar++typeLitPromotedConstructor :: ((MonadParsec e String) m) => m TypeExpr+typeLitPromotedConstructor = do+ _ <- char '\'' <* optional hspace+ TypeLitPromotedConstructor <$> typeConstructor++listType :: ((MonadParsec e String) m) => m TypeExpr+listType = do+ t <- whitespaceBetween '[' ']' innerTypeExpr+ pure $ TypeApplication (TypeConstructorExpr ListConstructor) [t]++-- | Given a TypeExpr, renders it back to a String in a canonical form that looks+-- normal to humans and is re-parseable when making an UnboundEntityDef that uses it.+--+-- @since 2.17.1.0+typeExprContent :: TypeExpr -> Text+typeExprContent = typeExprContent' Outer++-- This is a little gnarly-looking. That's mostly due to attempting to avoid inserting+-- superfluous parentheses.+typeExprContent' :: IsInner -> TypeExpr -> Text+typeExprContent' isInner = \case+ TypeLitString s ->+ mconcat+ [ "\""+ , T.pack s+ , "\""+ ]+ TypeLitInt s -> T.pack s+ TypeLitPromotedConstructor tc -> "'" <> typeExprContent' isInner (TypeConstructorExpr tc)+ TypeConstructorExpr (TypeConstructor s) -> T.pack s+ TypeConstructorExpr ListConstructor -> "List"+ TypeApplication (TypeConstructorExpr tc) args -> simpleTypeApplicationContent tc args isInner+ TypeApplication t exps ->+ mconcat+ [ typeExprContent' Inner t+ , " "+ , T.intercalate " " $ fmap typeExprContent exps+ ]+ where+ typeArgsListContent :: IsInner -> [TypeExpr] -> Text+ typeArgsListContent i exps = T.intercalate " " $ fmap (typeExprContent' i) exps++ simpleTypeApplicationContent :: TypeConstructor -> [TypeExpr] -> IsInner -> Text+ simpleTypeApplicationContent ListConstructor args _ =+ mconcat+ [ "["+ , typeArgsListContent Outer args+ , "]"+ ]+ simpleTypeApplicationContent (TypeConstructor s) [] _ = T.pack s+ simpleTypeApplicationContent (TypeConstructor s) exps Inner =+ mconcat+ [ "("+ , simpleTypeApplicationContent (TypeConstructor s) exps Outer+ , ")"+ ]+ simpleTypeApplicationContent (TypeConstructor s) exps Outer =+ mconcat+ [ T.pack s+ , " "+ , typeArgsListContent Inner exps+ ]
+ Database/Persist/Quasi/PersistSettings.hs view
@@ -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
+ Database/Persist/Quasi/PersistSettings/Internal.hs view
@@ -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+ -- <https://github.com/yesodweb/persistent/wiki/Persistent-entity-syntax>+ --+ -- @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}
Database/Persist/Sql.hs view
@@ -8,53 +8,65 @@ -- -- Then, you'll use the operations module Database.Persist.Sql- (- -- * 'RawSql' and 'PersistFieldSql'+ ( -- * 'RawSql' and 'PersistFieldSql' module Database.Persist.Sql.Class- -- * Running actions- -- | Run actions in a transaction with 'runSqlPool'.++ -- * Running actions++ -- | Run actions in a transaction with 'runSqlPool'. , module Database.Persist.Sql.Run- -- * Migrations++ -- * 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.++ -- * @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 <https://hackage.haskell.org/package/esqueleto- -- esqueleto> for a more powerful SQL query library built on @persistent@.++ -- * 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 <https://hackage.haskell.org/package/esqueleto+ -- esqueleto> for a more powerful SQL query library built on @persistent@. , rawQuery , rawQueryRes , rawExecute , rawExecuteCount , rawSql- -- * SQL helpers++ -- * SQL helpers , deleteWhereCount , updateWhereCount , filterClause , filterClauseWithVals , orderClause , FilterTablePrefix (..)- -- * Transactions++ -- * Transactions , transactionSave , transactionSaveWithIsolation , transactionUndo , transactionUndoWithIsolation- -- * Other utilities++ -- * Other utilities , getStmtConn , mkColumns , BackendSpecificOverrides , emptyBackendSpecificOverrides , getBackendSpecificForeignKeyName , setBackendSpecificForeignKeyName+ , getBackendSpecificForeignKeyCascadeDefault+ , setBackendSpecificForeignKeyCascadeDefault , defaultAttribute+ -- * Internal- , IsolationLevel(..)+ , IsolationLevel (..) , decorateSQLWithLimitOffset , module Database.Persist.Sql.Types ) where@@ -69,7 +81,10 @@ 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.Types.Internal+ ( IsolationLevel (..)+ , SqlBackend (..)+ ) import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore@@ -80,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.@@ -100,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)
Database/Persist/Sql/Class.hs view
@@ -10,1271 +10,15257 @@ 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' <https://www.postgresql.org/docs/current/static/sql-createdomain.html DOMAIN> and <https://www.postgresql.org/docs/current/static/datatype-enum.html ENUM> 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+ , 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' <https://www.postgresql.org/docs/current/static/sql-createdomain.html DOMAIN> and <https://www.postgresql.org/docs/current/static/datatype-enum.html ENUM> 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
Database/Persist/Sql/Internal.hs view
@@ -7,9 +7,11 @@ module Database.Persist.Sql.Internal ( mkColumns , defaultAttribute- , BackendSpecificOverrides(..)+ , BackendSpecificOverrides (..) , getBackendSpecificForeignKeyName , setBackendSpecificForeignKeyName+ , getBackendSpecificForeignKeyCascadeDefault+ , setBackendSpecificForeignKeyCascadeDefault , emptyBackendSpecificOverrides ) where @@ -34,7 +36,9 @@ -- -- @since 2.11 data BackendSpecificOverrides = BackendSpecificOverrides- { backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)+ { backendSpecificForeignKeyName+ :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)+ , backendSpecificForeignKeyCascadeDefault :: CascadeAction } -- | If the override is defined, then this returns a function that accepts an@@ -58,8 +62,28 @@ -> BackendSpecificOverrides -> BackendSpecificOverrides setBackendSpecificForeignKeyName func bso =- bso { backendSpecificForeignKeyName = Just func }+ 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 @@ -67,7 +91,7 @@ -- -- @since 2.11 emptyBackendSpecificOverrides :: BackendSpecificOverrides-emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing+emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing Restrict defaultAttribute :: [FieldAttr] -> Maybe Text defaultAttribute = findMaybe $ \case@@ -108,26 +132,25 @@ -- 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.+ -- 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+ , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd , cReference = mkColumnReference fd }@@ -146,7 +169,7 @@ , cSqlType = fieldSqlType fd , cDefault = defaultAttribute $ fieldAttrs fd , cGenerated = fieldGenerated fd- , cDefaultConstraintName = Nothing+ , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd , cReference = mkColumnReference fd }@@ -161,21 +184,24 @@ mkColumnReference :: FieldDef -> Maybe ColumnReference mkColumnReference fd = fmap- (\(tName, cName) ->+ ( \(tName, cName) -> ColumnReference tName cName $ overrideNothings $ fieldCascade fd )- $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs 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 }) =+ overrideNothings (FieldCascade{fcOnUpdate = upd, fcOnDelete = del}) = FieldCascade- { fcOnUpdate = upd <|> Just Restrict- , fcOnDelete = del <|> Just Restrict+ { fcOnUpdate = upd <|> Just defaultAction+ , fcOnDelete = del <|> Just defaultAction }+ where+ defaultAction = (backendSpecificForeignKeyCascadeDefault overrides) - ref :: FieldNameDB+ ref+ :: FieldNameDB -> ReferenceDef -> [FieldAttr] -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name@@ -183,11 +209,11 @@ | ForeignRef f <- fe = Just (resolveTableName allDefs f, refNameFn tableName c) | otherwise = Nothing- ref _ _ (FieldAttrNoreference:_) = Nothing- ref c fe (a:as) = case a of+ ref _ _ (FieldAttrNoreference : _) = Nothing+ ref c fe (a : as) = case a of FieldAttrReference x -> do (_, constraintName) <- ref c fe as- pure (EntityNameDB x, constraintName)+ pure (EntityNameDB x, constraintName) FieldAttrConstraint x -> do (tableName_, _) <- ref c fe as pure (tableName_, ConstraintNameDB x)@@ -199,6 +225,6 @@ resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t-resolveTableName (e:es) hn+resolveTableName (e : es) hn | getEntityHaskellName e == hn = getEntityDBName e | otherwise = resolveTableName es hn
Database/Persist/Sql/Migration.hs view
@@ -2,64 +2,66 @@ -- -- A 'Migration' is (currently) an alias for a 'WriterT' of module Database.Persist.Sql.Migration- (- -- * 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+ ( -- * 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.Class (MonadTrans (..))+import Control.Monad.Trans.Reader (ReaderT (..), ask) import Control.Monad.Trans.Writer import Data.Text (Text, isPrefixOf, pack, snoc, unpack) import qualified Data.Text.IO@@ -67,12 +69,12 @@ import System.IO import System.IO.Silently (hSilence) +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 Control.Exception (Exception(..)) type Sql = Text @@ -90,7 +92,8 @@ -- * @'ReaderT' 'SqlBackend'@, aka the 'SqlPersistT' transformer for -- database interop. -- * @'IO'@ for arbitrary IO.-type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) ()+type Migration =+ WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) () allSql :: CautiousMigration -> [Sql] allSql = map snd@@ -100,7 +103,9 @@ -- | 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 :: (HasCallStack, 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@@ -111,35 +116,41 @@ -- | Like 'parseMigration', but instead of returning the value in an -- 'Either' value, it calls 'error' on the error values.-parseMigration' :: (HasCallStack, 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 :: (HasCallStack, 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 :: (HasCallStack, 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, HasCallStack) => 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 throws a 'PersistUnsafeMigrationException'.-runMigration :: MonadIO m- => Migration- -> ReaderT SqlBackend m ()+runMigration+ :: (MonadIO m)+ => Migration+ -> ReaderT SqlBackend m () runMigration m = runMigration' m False >> return () -- | Same as 'runMigration', but does not report the individual migrations on@@ -150,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@@ -162,11 +174,12 @@ -- 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@@ -174,7 +187,8 @@ runMigration' :: (HasCallStack, MonadIO m) => Migration- -> Bool -- ^ is silent?+ -> Bool+ -- ^ is silent? -> ReaderT SqlBackend m [Text] runMigration' m silent = do mig <- parseMigration' m@@ -184,29 +198,32 @@ -- | 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 :: (HasCallStack, MonadIO m)- => Migration- -> ReaderT SqlBackend m [Text]+runMigrationUnsafeQuiet+ :: (HasCallStack, MonadIO m)+ => Migration+ -> ReaderT SqlBackend m [Text] runMigrationUnsafeQuiet = runMigrationUnsafe' True -runMigrationUnsafe' :: (HasCallStack, 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 []@@ -225,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@@ -286,21 +304,21 @@ -- -- @since 2.11.1.0 newtype PersistUnsafeMigrationException- = PersistUnsafeMigrationException [(Bool, Sql)]+ = 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 ++ ";"+ 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
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-}- {-# OPTIONS_GHC -fno-warn-orphans #-} -- | TODO: delete this module and get it in with SqlBackend.Internal@@ -26,7 +25,7 @@ import Data.Int (Int64) import Data.List (find, inits, transpose) import Data.Maybe (isJust)-import Data.Monoid (Monoid(..))+import Data.Monoid (Monoid (..)) import Data.Text (Text) import qualified Data.Text as T @@ -34,54 +33,67 @@ import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types.Internal- (SqlBackend(..), SqlReadBackend, SqlWriteBackend)+ ( SqlBackend (..)+ , SqlReadBackend+ , SqlWriteBackend+ ) import Database.Persist.Sql.Util- ( commaSeparated- , dbIdColumns- , isIdField- , keyAndEntityColumnNames- , mkUpdateText- , parseEntityValues- , parseExistsResult- , updatePersistValue- )+ ( 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 Nothing conn filts- let sql = mconcat- [ "SELECT COUNT(*) FROM "- , connEscapeTableName conn t- , wher- ]+ 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+ let+ wher =+ if null filts then "" else filterClause Nothing conn filts- let sql = mconcat- [ "SELECT EXISTS(SELECT 1 FROM "- , connEscapeTableName conn t- , wher- , ")"- ]+ 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"@@ -98,24 +110,29 @@ parse vals = case parseEntityValues t vals of Left s ->- liftIO $ throwIO $- PersistMarshalError ("selectSourceRes: " <> s <> ", vals: " <> T.pack (show vals ))+ 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 Nothing conn filts+ 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- ]+ sql conn =+ connLimitOffset conn (limit, offset) $+ mconcat+ [ "SELECT "+ , cols conn+ , " FROM "+ , connEscapeTableName conn t+ , wher conn+ , ord conn+ ] selectKeysRes filts opts = do conn <- ask@@ -125,18 +142,20 @@ t = entityDef $ dummyFromFilts filts cols conn = T.intercalate "," $ toList $ dbIdColumns conn t -- 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- ]+ 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 @@ -144,15 +163,20 @@ 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 $ 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+ 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@@ -181,56 +205,80 @@ -- | 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+ :: ( 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 Nothing conn filts- sql = mconcat- [ "DELETE FROM "- , connEscapeTableName conn t- , wher- ]+ 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 = withCompatibleBackend $ do conn <- ask- let wher = if null filts+ let+ wher =+ if null filts then "" 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+ 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) => EntityField record typ -> FieldNameDB+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)- => SqlBackend -> [Filter val] -> [PersistValue]+getFiltsValues+ :: forall val+ . (PersistEntity val)+ => SqlBackend -> [Filter val] -> [PersistValue] getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo@@ -239,22 +287,24 @@ -- -- @since 2.12.1.0 data FilterTablePrefix- = PrefixTableName- -- ^ Prefix the column with the table name. This is useful if the column- -- name might be ambiguous.- --- -- @since 2.12.1.0- | PrefixExcluded- -- ^ 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+ = -- | 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+ -> Text+ -- ^ Table name+ -> (Text -> Text)+ -- ^ Prefixing function prefixByTable tablePrefix tableName = case tablePrefix of Just PrefixTableName -> ((tableName <> ".") <>)@@ -263,16 +313,20 @@ filterClauseHelper :: (PersistEntity val)- => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED- -> Bool -- ^ include WHERE+ => 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+ ( if not (T.null sql) && includeWhere then " WHERE " <> sql- else sql, vals)+ else sql+ , vals+ ) where (sql, vals) = combineAND filters combineAND = combine " AND "@@ -287,112 +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+ 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, 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+ 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)-+ 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@@ -400,25 +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 = connEscapeTableName conn $ entityDef $ dummyFromFilts [Filter field value pfilter]+ 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 = ">"@@ -433,11 +569,13 @@ -- into a SQL query. -- -- @since 2.12.1.0-filterClause :: (PersistEntity val)- => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED- -> SqlBackend- -> [Filter val]- -> Text+filterClause+ :: (PersistEntity val)+ => Maybe FilterTablePrefix+ -- ^ include table name or EXCLUDED+ -> SqlBackend+ -> [Filter val]+ -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion@@ -445,60 +583,72 @@ -- @?@ 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+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+ :: (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)+ " 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 _ = Nothing tn = connEscapeTableName conn (entityDef $ dummyFromOrder orders) - name :: (PersistEntity record)- => EntityField record typ -> Text+ name+ :: (PersistEntity record)+ => EntityField record typ -> Text name x =- prefixByTable includeTable tn- $ connEscapeFieldName 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)+ -> (Int, Int) -> Text -> Text-decorateSQLWithLimitOffset nolimit (limit,offset) sql =+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
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -3,12 +3,11 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-}- {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore ( withRawQuery- , BackendKey(..)+ , BackendKey (..) , toSqlKey , fromSqlKey , getFieldName@@ -45,40 +44,41 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Util- ( commaSeparated- , dbIdColumns- , keyAndEntityColumnNames- , mkInsertValues- , mkUpdateText- , parseEntityValues- , updatePersistValue- )+ ( 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 "- $ Foldable.toList- $ fmap (<> "=? ")- $ 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 PersistEntity represents@@ -86,11 +86,13 @@ -- -- 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+ :: forall record m backend+ . ( PersistEntity record+ , BackendCompatible SqlBackend backend+ , Monad m+ )+ => record -> ReaderT backend m Text getTableName rec = withCompatibleBackend $ do conn <- ask return $ connEscapeTableName conn (entityDef $ Just rec)@@ -104,36 +106,77 @@ -- -- 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+ :: 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 $ connEscapeFieldName conn (fieldDB $ persistFieldDef rec) -- | useful for a backend to implement fieldName by adding escaping-fieldDBName :: forall record typ. (PersistEntity record) => EntityField record typ -> FieldNameDB+fieldDBName+ :: forall record typ+ . (PersistEntity record) => EntityField record typ -> FieldNameDB fieldDBName = fieldDB . persistFieldDef - instance PersistCore SqlBackend where- newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 }+ 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)+ 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 }+ 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)+ 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 }+ 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)+ deriving newtype+ ( Num+ , Integral+ , PersistField+ , PersistFieldSql+ , PathPiece+ , ToHttpApiData+ , FromHttpApiData+ , Real+ , Enum+ , Bounded+ , A.ToJSON+ , A.FromJSON+ ) instance BackendCompatible SqlBackend SqlBackend where projectBackend = id@@ -148,22 +191,26 @@ update _ [] = return () update k upds = do conn <- ask- 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- ]+ 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+ let+ vals = mkInsertValues val+ case connInsertSql conn (entityDef (Just val)) vals of ISRSingle sql -> do withRawQuery sql vals $ do pure ()@@ -174,34 +221,48 @@ 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.@@ -214,18 +275,23 @@ 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 = 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+ 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@@ -241,39 +307,49 @@ 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 mkInsertValues vals+ where+ ent = entityDef vals+ valss = map mkInsertValues vals insertMany_ vals0 = runChunked (length $ getEntityFields t) insertMany_' vals0 where t = entityDef vals0 insertMany_' vals = do- 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)+ 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 "- , connEscapeTableName conn t- , " SET "- , T.intercalate "," (map (go conn . fieldDB) $ getEntityFields t)- , " WHERE "- , wher- ]+ 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@@ -283,8 +359,10 @@ 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"@@ -294,35 +372,41 @@ 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+ 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+ Just _ -> mkInsertValues r case connRepsertManySql conn of (Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals krs) Nothing -> mapM_ repsert' krs where repsert' (key, value) = do- mExisting <- get key- case mExisting of- Nothing -> insertKey key value- Just _ -> replace key value+ 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 "- , connEscapeTableName conn (entityDef $ Just $ 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 = withBaseBackend $ insert v insertMany vs = withBaseBackend $ insertMany vs@@ -341,24 +425,32 @@ 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 . 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)+ 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@@ -377,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 = Foldable.toList $ 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 "- , connEscapeTableName conn entDef- , "("- , T.intercalate "," columnNames- , ") VALUES ("- , T.intercalate "),(" $ replicate (length es) $ T.intercalate "," $ fmap (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@@ -406,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]]
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE ExplicitForAll #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.Sql.Orphan.PersistUnique- ()- where+{-# OPTIONS_GHC -fno-warn-orphans #-} +module Database.Persist.Sql.Orphan.PersistUnique ()+where+ import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ask)@@ -15,44 +15,52 @@ import Database.Persist import Database.Persist.Class.PersistUnique- (defaultPutMany, defaultUpsertBy, persistUniqueKeyValues)+ ( defaultPutMany+ , defaultUpsertBy+ , persistUniqueKeyValues+ ) 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- )+ ( dbColumns+ , mkUpdateText'+ , parseEntityValues+ , parseExistsResult+ , updatePersistValue+ ) instance PersistUniqueWrite SqlBackend where 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+ 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 -> defaultUpsertBy uniqueKey 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@@ -64,20 +72,26 @@ [ "DELETE FROM " , 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)@@ -91,25 +105,28 @@ instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask- let sql =+ let+ sql = T.concat [ "SELECT " , T.intercalate "," $ toList $ dbColumns conn t , " FROM " , 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@@ -119,7 +136,8 @@ existsBy uniq = do conn <- ask- let sql =+ let+ sql = T.concat [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t
Database/Persist/Sql/Raw.hs view
@@ -19,10 +19,11 @@ 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@@ -36,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@@ -45,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@@ -67,40 +77,44 @@ return res getStmt- :: (MonadIO m, MonadReader backend m, BackendCompatible SqlBackend backend)- => Text -> 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- let cacheK = mkCacheKeyFromQuery sql+ 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- }+ 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@@ -202,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 (connEscapeRawName 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 :))
Database/Persist/Sql/Run.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Database.Persist.Sql.Run where +import Control.Monad (void) import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack-import Control.Monad (void) 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.Acquire (Acquire, ReleaseType (..), mkAcquireType, with) import Data.Pool as P import qualified Data.Text as T import qualified UnliftIO.Exception as UE@@ -19,8 +20,8 @@ import Database.Persist.Sql.Raw import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal-import Database.Persist.SqlBackend.Internal.StatementCache 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.@@ -32,7 +33,8 @@ -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. runSqlPool- :: forall backend m a. (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 = do rawRunSqlPool r pconn Nothing@@ -41,7 +43,8 @@ -- -- @since 2.9.0 runSqlPoolWithIsolation- :: forall backend m a. (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)@@ -51,28 +54,36 @@ -- -- @since 2.12.0.0 runSqlPoolNoTransaction- :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)+ :: 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)+ :: 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+ let+ sqlBackend = projectBackend conn+ let+ getter = getStmtConn sqlBackend liftIO $ connBegin sqlBackend getter mi after conn = do- let sqlBackend = projectBackend conn- let getter = getStmtConn sqlBackend+ let+ sqlBackend = projectBackend conn+ let+ getter = getStmtConn sqlBackend liftIO $ connCommit sqlBackend getter onException conn _ = do- let sqlBackend = projectBackend conn- let getter = getStmtConn sqlBackend+ let+ sqlBackend = projectBackend conn+ let+ getter = getStmtConn sqlBackend liftIO $ connRollback sqlBackend getter -- | This function is how 'runSqlPool' and 'runSqlPoolNoTransaction' are@@ -82,7 +93,8 @@ -- -- @since 2.12.0.0 runSqlPoolWithHooks- :: forall backend m a before after onException. (MonadUnliftIO m, BackendCompatible SqlBackend backend)+ :: forall backend m a before after onException+ . (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel@@ -96,12 +108,13 @@ -- 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- }+ 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. --@@ -109,7 +122,8 @@ -- -- @since 2.13.0.0 runSqlPoolWithExtensibleHooks- :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend)+ :: forall backend m a+ . (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel@@ -117,16 +131,17 @@ -> m a runSqlPoolWithExtensibleHooks r pconn i SqlPoolHooks{..} = withRunInIO $ \runInIO ->- 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+ 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@@ -134,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@@ -176,15 +192,21 @@ => IsolationLevel -> m (Acquire backend) acquireSqlConnWithIsolation = rawAcquireSqlConn . Just -runSqlConn :: forall backend m a. (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 :: forall backend m a. (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)@@ -197,64 +219,84 @@ runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool liftSqlPersistMPool- :: forall backend m a. (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- :: forall backend m a. (MonadLoggerIO 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 = withSqlPoolWithConfig mkConn (defaultConnectionPoolConfig { connectionPoolConfigSize = connCount } ) 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+ :: 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)+withSqlPoolWithConfig mkConn poolConfig f = withUnliftIO $ \u ->+ UE.bracket+ (unliftIO u $ createSqlPoolWithConfig mkConn poolConfig)+ destroyAllResources+ (unliftIO u . f) createSqlPool- :: forall backend m. (MonadLoggerIO 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 = createSqlPoolWithConfig mkConn (defaultConnectionPoolConfig { connectionPoolConfigSize = size } )+createSqlPool mkConn size =+ createSqlPoolWithConfig+ mkConn+ (defaultConnectionPoolConfig{connectionPoolConfigSize = size}) -- | Creates a pool of connections to a SQL database. -- -- @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+ :: 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)+ 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.@@ -306,20 +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- :: forall backend m a. (MonadUnliftIO m, MonadLoggerIO 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 <- askLoggerIO- withRunInIO $ \run -> UE.bracket- (open logFunc)- close'- (run . f)+ withRunInIO $ \run ->+ UE.bracket+ (open logFunc)+ close'+ (run . f) close' :: (BackendCompatible SqlBackend backend) => backend -> IO () close' conn = do- let backend = projectBackend conn+ let+ backend = projectBackend conn statementCacheClear $ connStmtMap backend connClose backend
Database/Persist/Sql/Types.hs view
@@ -1,16 +1,26 @@ module Database.Persist.Sql.Types ( module Database.Persist.Sql.Types- , SqlBackend, SqlReadBackend (..), SqlWriteBackend (..)- , Statement (..), LogFunc, InsertSqlResult (..)- , readToUnknown, readToWrite, writeToUnknown- , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend- , OverflowNatural(..)- , ConnectionPoolConfig(..)+ , 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.Reader (ReaderT (..)) import Control.Monad.Trans.Resource (ResourceT) import Data.Pool (Pool) import Data.Text (Text)@@ -20,13 +30,13 @@ import Database.Persist.Types data Column = Column- { cName :: !FieldNameDB- , cNull :: !Bool- , cSqlType :: !SqlType- , cDefault :: !(Maybe Text)+ { cName :: !FieldNameDB+ , cNull :: !Bool+ , cSqlType :: !SqlType+ , cDefault :: !(Maybe Text) , cGenerated :: !(Maybe Text)- , cDefaultConstraintName :: !(Maybe ConstraintNameDB)- , cMaxLen :: !(Maybe Integer)+ , cDefaultConstraintName :: !(Maybe ConstraintNameDB)+ , cMaxLen :: !(Maybe Integer) , cReference :: !(Maybe ColumnReference) } deriving (Eq, Ord, Show)@@ -51,9 +61,10 @@ } deriving (Eq, Ord, Show) -data PersistentSqlException = StatementAlreadyFinalized Text- | Couldn'tGetSQLConnection- deriving Show+data PersistentSqlException+ = StatementAlreadyFinalized Text+ | Couldn'tGetSQLConnection+ deriving (Show) instance Exception PersistentSqlException type SqlPersistT = ReaderT SqlBackend@@ -66,13 +77,17 @@ -- -- @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+ { 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) -- 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@@ -131,10 +146,8 @@ -- 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 -- processing). newtype Single a = Single {unSingle :: a} deriving (Eq, Ord, Show, Read)-
Database/Persist/Sql/Types/Internal.hs view
@@ -33,16 +33,16 @@ import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Database.Persist.Class- ( BackendCompatible(..)- , HasPersistBackend(..)- , PersistQueryRead- , PersistQueryWrite- , PersistStoreRead- , PersistStoreWrite- , PersistUniqueRead- , PersistUniqueWrite- )-import Database.Persist.Class.PersistStore (IsPersistBackend(..))+ ( BackendCompatible (..)+ , HasPersistBackend (..)+ , PersistQueryRead+ , PersistQueryWrite+ , PersistStoreRead+ , PersistStoreWrite+ , PersistUniqueRead+ , PersistUniqueWrite+ )+import Database.Persist.Class.PersistStore (IsPersistBackend (..)) import Database.Persist.SqlBackend.Internal import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel@@ -52,7 +52,7 @@ -- | An SQL backend which can only handle read queries -- -- The constructor was exposed in 2.10.0.-newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend }+newtype SqlReadBackend = SqlReadBackend {unSqlReadBackend :: SqlBackend} instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend@@ -64,7 +64,7 @@ -- | An SQL backend which can handle read or write queries -- -- The constructor was exposed in 2.10.0-newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend }+newtype SqlWriteBackend = SqlWriteBackend {unSqlWriteBackend :: SqlBackend} instance HasPersistBackend SqlWriteBackend where type BaseBackend SqlWriteBackend = SqlBackend@@ -74,40 +74,49 @@ 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+ , 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+ , 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 =
Database/Persist/Sql/Util.hs view
@@ -23,44 +23,45 @@ import Data.ByteString.Char8 (readInteger) import Data.Int (Int64)-import Data.List.NonEmpty (NonEmpty(..))+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- , FieldDef(..)- , FieldNameDB- , FieldNameHS(FieldNameHS)- , PersistEntity(..)- , PersistUpdate(..)- , PersistValue(..)- , Update(..)- , compositeFields- , entityPrimary- , fieldDB- , fieldHaskell- , fromPersistValues- , getEntityFields- , getEntityKeyFields- , keyAndEntityFields- , keyFromValues- , persistFieldDef- , toPersistValue- )+ ( Entity (Entity)+ , EntityDef+ , EntityField+ , FieldDef (..)+ , FieldNameDB+ , FieldNameHS (FieldNameHS)+ , PersistEntity (..)+ , PersistUpdate (..)+ , PersistValue (..)+ , Update (..)+ , compositeFields+ , entityPrimary+ , fieldDB+ , fieldHaskell+ , fromPersistValues+ , getEntityFields+ , getEntityKeyFields+ , keyAndEntityFields+ , keyFromValues+ , persistFieldDef+ , toPersistValue+ ) -import Database.Persist.SqlBackend.Internal (SqlBackend(..))+import Database.Persist.SqlBackend.Internal (SqlBackend (..)) keyAndEntityColumnNames :: EntityDef -> SqlBackend -> NonEmpty Text keyAndEntityColumnNames ent conn = fmap (connEscapeFieldName conn . fieldDB) (keyAndEntityFields ent) entityColumnCount :: EntityDef -> Int-entityColumnCount e = length (getEntityFields e)- + if hasNaturalKey e then 0 else 1+entityColumnCount e =+ length (getEntityFields e)+ + if hasNaturalKey e then 0 else 1 -- | Returns 'True' if the entity has a natural key defined with the -- Primary keyword.@@ -163,47 +164,52 @@ where 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 = fmap fieldHaskell $ compositeFields pdef- keyvals = map snd . filter ((`elem` pks) . fst)- $ zip (map fieldHaskell $ getEntityFields 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 err -> error $ "fromPersistValuesComposite': keyFromValues failed with error: "- <> T.unpack err+ Left err ->+ error $+ "fromPersistValuesComposite': keyFromValues failed with error: "+ <> T.unpack err Right key -> Right (Entity key xs') - isIdField- :: forall record typ. (PersistEntity record)+ :: 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@@ -213,20 +219,23 @@ commaSeparated :: [Text] -> Text commaSeparated = T.intercalate ", " -mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text+mkUpdateText :: (PersistEntity record) => SqlBackend -> Update record -> Text mkUpdateText conn = mkUpdateText' (connEscapeFieldName conn) id -- TODO: incorporate the table names into a sum type-mkUpdateText' :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text+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 @@ -240,7 +249,7 @@ -- -- @since 2.11.0.0 mkInsertValues- :: PersistEntity rec+ :: (PersistEntity rec) => rec -> [PersistValue] mkInsertValues entity =@@ -277,11 +286,21 @@ parseExistsResult :: Maybe [PersistValue] -> Text -> String -> Bool parseExistsResult mm sql errloc = case mm of- Just [PersistBool b] -> b -- Postgres+ 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+ 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
Database/Persist/SqlBackend.hs view
@@ -5,14 +5,14 @@ ( -- * The type and construction SqlBackend , mkSqlBackend- , MkSqlBackendArgs(..)+ , MkSqlBackendArgs (..) , SqlBackendHooks , emptySqlBackendHooks- -- * Utilities - -- $utilities+ -- * Utilities+ -- $utilities - -- ** SqlBackend Getters+ -- ** SqlBackend Getters , getRDBMS , getEscapedFieldName , getEscapedRawName@@ -21,7 +21,8 @@ , getConnUpsertSql , getConnVault , getConnHooks- -- ** SqlBackend Setters++ -- ** SqlBackend Setters , setConnMaxParams , setConnRepsertManySql , setConnInsertManySql@@ -30,21 +31,24 @@ , setConnVault , modifyConnVault , setConnHooks- -- ** SqlBackendHooks++ -- ** 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.Class.PersistStore (BackendCompatible (..)) import Database.Persist.Names import Database.Persist.SqlBackend.Internal import qualified Database.Persist.SqlBackend.Internal as SqlBackend- (SqlBackend(..))+ ( SqlBackend (..)+ ) import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk- (MkSqlBackendArgs(..))+ ( MkSqlBackendArgs (..)+ ) import Database.Persist.Types.Base -- $utilities@@ -144,7 +148,7 @@ -- -- @since 2.13.3.0 getConnVault- :: (BackendCompatible SqlBackend backend, MonadReader backend m)+ :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m Vault getConnVault = do asks (SqlBackend.connVault . projectBackend)@@ -153,7 +157,7 @@ -- -- @since 2.13.3.0 getConnHooks- :: (BackendCompatible SqlBackend backend, MonadReader backend m)+ :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m SqlBackendHooks getConnHooks = do asks (SqlBackend.connHooks . projectBackend)@@ -168,7 +172,6 @@ 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. --@@ -178,7 +181,7 @@ -> SqlBackend -> SqlBackend setConnMaxParams i sb =- sb { connMaxParams = Just i }+ 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@@ -190,7 +193,7 @@ -> SqlBackend -> SqlBackend setConnRepsertManySql mkQuery sb =- sb { connRepsertManySql = Just mkQuery }+ 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@@ -202,7 +205,7 @@ -> SqlBackend -> SqlBackend setConnInsertManySql mkQuery sb =- sb { connInsertManySql = Just mkQuery }+ 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@@ -214,7 +217,7 @@ -> SqlBackend -> SqlBackend setConnUpsertSql mkQuery sb =- sb { connUpsertSql = Just mkQuery }+ 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@@ -225,26 +228,26 @@ :: (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend-setConnPutManySql mkQuery sb =- sb { connPutManySql = Just mkQuery }+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 }+ sb{connVault = vault} -- | Modify the vault on the provided database backend. -- -- @since 2.13.0-modifyConnVault :: (Vault -> Vault) -> SqlBackend -> SqlBackend+modifyConnVault :: (Vault -> Vault) -> SqlBackend -> SqlBackend modifyConnVault f sb =- sb { connVault = f $ connVault 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 }+ sb{connHooks = hooks}
Database/Persist/SqlBackend/Internal.hs view
@@ -44,7 +44,8 @@ -- ^ 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)+ , connUpsertSql+ :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) -- ^ Some databases support performing UPSERT _and_ RETURN entity -- in a single call. --@@ -110,7 +111,7 @@ -- ^ 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+ , 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.@@ -146,9 +147,10 @@ } emptySqlBackendHooks :: SqlBackendHooks-emptySqlBackendHooks = SqlBackendHooks- { hookGetStatement = \_ _ s -> pure s- }+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@@ -157,7 +159,7 @@ -- -- @since 2.13.0.0 mkSqlBackend :: MkSqlBackendArgs -> SqlBackend-mkSqlBackend MkSqlBackendArgs {..} =+mkSqlBackend MkSqlBackendArgs{..} = SqlBackend { connMaxParams = Nothing , connRepsertManySql = Nothing
Database/Persist/SqlBackend/Internal/InsertSqlResult.hs view
@@ -1,7 +1,7 @@ module Database.Persist.SqlBackend.Internal.InsertSqlResult where -import Database.Persist.Types.Base (PersistValue) import Data.Text (Text)+import Database.Persist.Types.Base (PersistValue) data InsertSqlResult = ISRSingle Text
Database/Persist/SqlBackend/Internal/IsolationLevel.hs view
@@ -1,18 +1,20 @@ module Database.Persist.SqlBackend.Internal.IsolationLevel where -import Data.String (IsString(..))+import Data.String (IsString (..)) -- | 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)+-- 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"+makeIsolationLevelStatement l =+ "SET TRANSACTION ISOLATION LEVEL " <> case l of+ ReadUncommitted -> "READ UNCOMMITTED"+ ReadCommitted -> "READ COMMITTED"+ RepeatableRead -> "REPEATABLE READ"+ Serializable -> "SERIALIZABLE"
Database/Persist/SqlBackend/Internal/MkSqlBackend.hs view
@@ -3,14 +3,14 @@ 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-import Data.Map (Map)-import Data.IORef (IORef) -- | 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@@ -68,7 +68,7 @@ -- ^ 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+ , 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.
Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs view
@@ -1,6 +1,7 @@ module Database.Persist.SqlBackend.Internal.SqlPoolHooks- ( SqlPoolHooks(..)- ) where+ ( SqlPoolHooks (..)+ ) where+ import Control.Exception (SomeException) import Database.Persist.SqlBackend.Internal.IsolationLevel
Database/Persist/SqlBackend/Internal/Statement.hs view
@@ -1,11 +1,11 @@-{-# language RankNTypes #-}+{-# LANGUAGE RankNTypes #-} module Database.Persist.SqlBackend.Internal.Statement where +import Conduit import Data.Acquire-import Database.Persist.Types.Base import Data.Int-import Conduit+import Database.Persist.Types.Base -- | A 'Statement' is a representation of a database query that has been -- prepared and stored on the server side.@@ -13,7 +13,9 @@ { stmtFinalize :: IO () , stmtReset :: IO () , stmtExecute :: [PersistValue] -> IO Int64- , stmtQuery :: forall m. MonadIO m- => [PersistValue]- -> Acquire (ConduitM () [PersistValue] m ())+ , stmtQuery+ :: forall m+ . (MonadIO m)+ => [PersistValue]+ -> Acquire (ConduitM () [PersistValue] m ()) }
Database/Persist/SqlBackend/Internal/StatementCache.hs view
@@ -14,7 +14,8 @@ , statementCacheSize :: IO Int } -newtype StatementCacheKey = StatementCacheKey { cacheKey :: Text }+newtype StatementCacheKey = StatementCacheKey {cacheKey :: Text}+ -- Wrapping around this to allow for more efficient keying mechanisms -- in the future, perhaps.
Database/Persist/SqlBackend/SqlPoolHooks.hs view
@@ -1,26 +1,26 @@ module Database.Persist.SqlBackend.SqlPoolHooks- ( SqlPoolHooks- , defaultSqlPoolHooks- , getAlterBackend- , modifyAlterBackend- , setAlterBackend- , getRunBefore- , modifyRunBefore- , setRunBefore- , getRunAfter- , modifyRunAfter- , setRunAfter- , getRunOnException- )- where+ ( 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.SqlPoolHooks import Database.Persist.SqlBackend.Internal.IsolationLevel-import Database.Persist.Class.PersistStore+import Database.Persist.SqlBackend.Internal.SqlPoolHooks -- | Lifecycle hooks that may be altered to extend SQL pool behavior -- in a backwards compatible fashion.@@ -33,60 +33,95 @@ -- - '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- }+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 }+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+ :: 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 }+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+ :: 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 }+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+ :: 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 }-+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}
Database/Persist/SqlBackend/StatementCache.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE RecordWildCards #-}+ module Database.Persist.SqlBackend.StatementCache- ( StatementCache- , StatementCacheKey- , mkCacheKeyFromQuery- , MkStatementCache(..)- , mkSimpleStatementCache- , mkStatementCache- ) where+ ( 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-import Data.Map (Map)-import Data.Text (Text) -- | Configuration parameters for creating a custom statement cache --@@ -43,7 +44,6 @@ -- @since 2.13.3 } - -- | Make a simple statement cache that will cache statements if they are not currently cached. -- -- @since 2.13.3@@ -54,7 +54,8 @@ , statementCacheInsert = \sql stmt -> modifyIORef' stmtMap (Map.insert (cacheKey sql) stmt) , statementCacheClear = do- oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements))+ oldStatements <-+ atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) traverse_ stmtFinalize oldStatements , statementCacheSize = Map.size <$> readIORef stmtMap }@@ -63,4 +64,4 @@ -- -- @since 2.13.0 mkStatementCache :: MkStatementCache -> StatementCache-mkStatementCache MkStatementCache{..} = StatementCache { .. }+mkStatementCache MkStatementCache{..} = StatementCache{..}
Database/Persist/TH.hs view
@@ -1,3427 +1,52 @@-{-# 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- ( -- * 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- , (.:)- , (.:?)- , (.=)- )-#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)-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.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 =- parseReferences ps . pack- , 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 <https://github.com/yesodweb/persistent/issues/778 persistent#778> and--- <https://github.com/yesodweb/persistent/pull/791 persistent#791> for more details.------ @since 2.5.4-persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp-persistManyFileWith ps fps = do- mapM_ qAddDependentFile fps- ss <- mapM (qRunIO . getFileContents) fps- let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put a line-break at EOF.- parseReferences ps s--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.5.3-parseReferences :: PersistSettings -> Text -> Q Exp-parseReferences ps s = lift $ parse ps s--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 to be passed to the 'mkPersist' function.-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 accessors and lens names using the entity and field- -- name. Both arguments are upper cased.- --- -- Default: appends entity and field.- --- -- Note: this setting is ignored if mpsPrefixFields is set to False.- --- -- @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 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)-#if MIN_VERSION_template_haskell(2,18,0)- 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 ()-#endif- 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)]--uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec-uniqueTypeDec mps entityMap entDef =- DataInstD- []-#if MIN_VERSION_template_haskell(2,15,0)- Nothing- (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT))-#else- ''Unique- [genericDataType mps (getUnboundEntityNameHS entDef) backendT]-#endif- Nothing- (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef))- []--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. ***" ]---- | 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--#if MIN_VERSION_template_haskell(2,15,0)- let kd = if useNewtype- then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses- else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses-#else- let kd = if useNewtype- then NewtypeInstD [] k [recordType] Nothing dec deriveClauses- else DataInstD [] k [recordType] Nothing [dec] deriveClauses-#endif- 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)---- | 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-- 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- , FunD 'entityDef [normalClause [WildP] entityDefExp]- , tpf- , FunD 'fromPersistValues fpv- , toFieldNames- , utv- , puk-#if MIN_VERSION_template_haskell(2,15,0)- , DataInstD- []- Nothing- (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ"))- Nothing- allEntDefs- []-#else- , DataInstD- []- ''EntityField- [ genDataType- , VarT $ mkName "typ"- ]- Nothing- allEntDefs- []-#endif- , FunD 'persistFieldDef allEntDefClauses-#if MIN_VERSION_template_haskell(2,15,0)- , TySynInstD- (TySynEqn- Nothing- (AppT (ConT ''PersistEntityBackend) genDataType)- (backendDataType mps))-#else- , TySynInstD- ''PersistEntityBackend- (TySynEqn- [genDataType]- (backendDataType mps))-#endif- , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)]- , FunD 'fieldLens lensClauses- ]- ] `mappend` lenses) `mappend` keyInstanceDecs- where- genDataType =- genericDataType mps entName backendT- entName =- getUnboundEntityNameHS preDef--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 '(.:?)-#if MIN_VERSION_aeson(2,0,0)- toKeyE = VarE 'Key.fromString-#else- toKeyE = VarE 'pack-#endif- 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--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--- <https://github.com/yesodweb/persistent/issues/412>-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))+-- | 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
+ Database/Persist/TH/Internal.hs view
@@ -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 <https://github.com/yesodweb/persistent/issues/778 persistent#778> and+-- <https://github.com/yesodweb/persistent/pull/791 persistent#791> 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+-- <https://github.com/yesodweb/persistent/issues/412>+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))
Database/Persist/Types.hs view
@@ -3,27 +3,35 @@ -- 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- (- -- * 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+ ( -- * 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'.++ -- * 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.++ -- ** 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.++ -- * Intermediate Values++ -- | The 'PersistValue' type is used as an intermediate layer between+ -- database and Haskell types. , module Database.Persist.PersistValue- -- * Other Useful Stuff++ -- * Other Useful Stuff , Update (..) , BackendSpecificUpdate , SelectOpt (..)@@ -32,8 +40,9 @@ , BackendSpecificFilter , Key , Entity (..)- , OverflowNatural(..)- -- * The rest of the types+ , OverflowNatural (..)++ -- * The rest of the types , module Database.Persist.Types.Base ) where @@ -48,32 +57,33 @@ -- 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- , noCascade- , parseFieldAttrs- )+ ( 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+ )
Database/Persist/Types/Base.hs view
@@ -9,35 +9,39 @@ module Database.Persist.Types.Base ( module Database.Persist.Types.Base- -- * Re-exports- , PersistValue(..)++ -- * Re-exports+ , PersistValue (..) , fromPersistValueText- , LiteralType(..)+ , LiteralType (..)+ , SourceSpan (..) ) where import Control.Exception (Exception) import Data.Char (isSpace)-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NEL import Data.Map (Map) import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word32)-import Language.Haskell.TH.Syntax (Lift(..))+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`+ ( 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@@ -81,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@@ -96,12 +101,12 @@ 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@@ -110,7 +115,7 @@ fieldAttrsContainsNullable :: [FieldAttr] -> IsNullable fieldAttrsContainsNullable s- | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr+ | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr | FieldAttrNullable `elem` s = Nullable ByNullableAttr | otherwise = NotNullable @@ -119,9 +124,10 @@ -- 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@@ -129,32 +135,40 @@ data EntityDef = EntityDef { entityHaskell :: !EntityNameHS -- ^ The name of the entity as Haskell understands it.- , entityDB :: !EntityNameDB+ , entityDB :: !EntityNameDB -- ^ The name of the database table corresponding to the entity.- , entityId :: !EntityIdDef+ , 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, Lift) @@ -162,18 +176,18 @@ -- -- @since 2.13.0.0 data EntityIdDef- = EntityIdField !FieldDef- -- ^ 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- | EntityIdNaturalKey !CompositeDef- -- ^ 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+ = -- | 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.@@ -213,7 +227,7 @@ -- -- For fields on the Haskell type use 'keyAndEntityFieldsDatabase' ----- @since 2.14.6.0+-- @since 2.15.1.0 keyAndEntityFieldsDatabase :: EntityDef -> NonEmpty FieldDef keyAndEntityFieldsDatabase ent = keyWithFields (entityId ent) fields@@ -228,11 +242,12 @@ 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."- ]+ error $+ mconcat+ [ "persistent internal guarantee failed: entity is "+ , "defined with an entityId = EntityIdNaturalKey, "+ , "but somehow doesn't have any entity fields."+ ] Just xs -> xs @@ -248,147 +263,147 @@ -- -- @since 2.11.0.0 data FieldAttr- = FieldAttrMaybe- -- ^ 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- -- @- | FieldAttrNullable- -- ^ 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- -- @- | FieldAttrMigrationOnly- -- ^ 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- -- @- | FieldAttrSafeToRemove- -- ^ 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- -- @- | FieldAttrNoreference- -- ^ 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- -- @- | FieldAttrReference Text- -- ^ 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.- | FieldAttrConstraint 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"- -- @- | FieldAttrDefault 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.- | FieldAttrSqltype 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"- -- @- | FieldAttrMaxlen Integer- -- ^ Set a maximum length for a column. Useful for VARCHAR and indexes.- --- -- @- -- User- -- name Text maxlen=200- --- -- UniqueName name- -- @- | FieldAttrSql Text- -- ^ 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.- | FieldAttrOther Text- -- ^ A grab bag of random attributes that were unrecognized by the parser.+ = -- | 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@@ -428,8 +443,8 @@ -- 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@@ -450,12 +465,12 @@ -- 3) embedded data ReferenceDef = NoReference- | ForeignRef !EntityNameHS- -- ^ 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+ | -- | 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- | SelfReference- -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311).+ | -- | 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@@ -463,14 +478,15 @@ -- so it only has data needed for embedding data EmbedEntityDef = EmbedEntityDef { embeddedHaskell :: EntityNameHS- , embeddedFields :: [EmbedFieldDef]- } deriving (Show, Eq, Read, Ord, Lift)+ , 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 :: FieldNameDB+ { emFieldDB :: FieldNameDB , emFieldEmbed :: Maybe (Either SelfEmbed EntityNameHS) } deriving (Show, Eq, Read, Ord, Lift)@@ -484,19 +500,20 @@ -- @since 2.13.0.0 isHaskellField :: FieldDef -> Bool isHaskellField fd =- FieldAttrMigrationOnly `notElem` fieldAttrs fd &&- FieldAttrSafeToRemove `notElem` fieldAttrs fd+ FieldAttrMigrationOnly `notElem` fieldAttrs fd+ && FieldAttrSafeToRemove `notElem` fieldAttrs fd toEmbedEntityDef :: EntityDef -> EmbedEntityDef toEmbedEntityDef ent = embDef where- embDef = EmbedEntityDef- { embeddedHaskell = entityHaskell ent- , embeddedFields =- map toEmbedFieldDef- $ filter isHaskellField- $ entityFields ent- }+ embDef =+ EmbedEntityDef+ { embeddedHaskell = entityHaskell ent+ , embeddedFields =+ map toEmbedFieldDef $+ filter isHaskellField $+ entityFields ent+ } toEmbedFieldDef :: FieldDef -> EmbedFieldDef toEmbedFieldDef field = EmbedFieldDef@@ -530,18 +547,17 @@ -- , uniqueAttrs = [] -- } -- @--- data UniqueDef = UniqueDef { uniqueHaskell :: !ConstraintNameHS- , uniqueDBName :: !ConstraintNameDB- , uniqueFields :: !(NonEmpty (FieldNameHS, FieldNameDB))- , uniqueAttrs :: ![Attr]+ , uniqueDBName :: !ConstraintNameDB+ , uniqueFields :: !(NonEmpty (FieldNameHS, FieldNameDB))+ , uniqueAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord, Lift) data CompositeDef = CompositeDef- { compositeFields :: !(NonEmpty FieldDef)- , compositeAttrs :: ![Attr]+ { compositeFields :: !(NonEmpty FieldDef)+ , compositeAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord, Lift) @@ -550,18 +566,18 @@ type ForeignFieldDef = (FieldNameHS, FieldNameDB) data ForeignDef = ForeignDef- { foreignRefTableHaskell :: !EntityNameHS- , foreignRefTableDBName :: !EntityNameDB+ { foreignRefTableHaskell :: !EntityNameHS+ , foreignRefTableDBName :: !EntityNameDB , foreignConstraintNameHaskell :: !ConstraintNameHS- , foreignConstraintNameDBName :: !ConstraintNameDB- , foreignFieldCascade :: !FieldCascade+ , 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+ , 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@@ -604,7 +620,7 @@ -- change. -- -- @since 2.11.0-data CascadeAction = Cascade | Restrict | SetNull | SetDefault+data CascadeAction = Cascade | Restrict | SetNull | SetDefault | NoAction deriving (Show, Eq, Read, Ord, Lift) -- | Render a 'CascadeAction' to 'Text' such that it can be used in a SQL@@ -613,44 +629,58 @@ -- @since 2.11.0 renderCascadeAction :: CascadeAction -> Text renderCascadeAction action = case action of- Cascade -> "CASCADE"- Restrict -> "RESTRICT"- SetNull -> "SET NULL"- SetDefault -> "SET DEFAULT"+ Cascade -> "CASCADE"+ Restrict -> "RESTRICT"+ SetNull -> "SET NULL"+ SetDefault -> "SET DEFAULT"+ NoAction -> "NO ACTION" data PersistException- = PersistError Text -- ^ Generic Exception- | PersistMarshalError Text- | PersistInvalidField Text- | PersistForeignConstraintUnmet Text- | PersistMongoDBError Text- | PersistMongoDBUnsupported Text- deriving Show+ = -- | Generic Exception+ PersistError Text+ | PersistMarshalError Text+ | PersistInvalidField Text+ | PersistForeignConstraintUnmet Text+ | PersistMongoDBError Text+ | PersistMongoDBUnsupported Text+ deriving (Show) 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+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+data PersistFilter+ = Eq+ | Ne+ | Gt+ | Lt+ | Ge+ | Le+ | In+ | NotIn+ | BackendSpecificFilter T.Text deriving (Read, Show, Lift) -data UpdateException = KeyNotFound String- | UpsertError String+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@@ -659,12 +689,15 @@ 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+ = Assign+ | Add+ | Subtract+ | Multiply+ | Divide | BackendSpecificUpdate T.Text deriving (Read, Show, Lift) @@ -672,23 +705,23 @@ -- 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+ { 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+ , fieldDB :: !FieldNameDB -- ^ The name of the field in the database. For SQL databases, this -- corresponds to the column name.- , fieldType :: !FieldType+ , fieldType :: !FieldType -- ^ The type of the field in Haskell.- , fieldSqlType :: !SqlType+ , fieldSqlType :: !SqlType -- ^ The type of the field in a SQL database.- , fieldAttrs :: ![FieldAttr]+ , fieldAttrs :: ![FieldAttr] -- ^ User annotations for a field. These are provided with the @!@ -- operator.- , fieldStrict :: !Bool+ , 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@@ -699,7 +732,7 @@ -- be the same as the one obtained in the 'fieldReference'. -- -- @since 2.11.0- , fieldComments :: !(Maybe Text)+ , fieldComments :: !(Maybe Text) -- ^ Optional comments for a 'Field'. -- -- @since 2.10.0
+ Database/Persist/Types/SourceSpan.hs view
@@ -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)
bench/Main.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}- {-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where@@ -14,109 +13,93 @@ 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))- -- ]- -- ]+main =+ defaultMain+ [ bgroup+ "mkPersist"+ [] ]- ] --- Orphan instances for NFData Template Haskell types-instance NFData Overlap where---instance NFData AnnTarget where--instance NFData RuleBndr where---instance NFData Role where---instance NFData Phases where---instance NFData InjectivityAnn where---instance NFData FamilyResultSig where---instance NFData RuleMatch where---instance NFData TypeFamilyHead where---instance NFData TySynEqn where---instance NFData Inline where+-- 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 Pragma where+instance NFData AnnTarget +instance NFData RuleBndr -instance NFData FixityDirection where+instance NFData Role +instance NFData Phases -instance NFData Safety where+instance NFData InjectivityAnn +instance NFData FamilyResultSig -instance NFData Fixity where+instance NFData RuleMatch +instance NFData TypeFamilyHead -instance NFData Callconv where+instance NFData TySynEqn +instance NFData Inline -instance NFData Foreign where+instance NFData Pragma +instance NFData FixityDirection -instance NFData SourceStrictness where+instance NFData Safety +instance NFData Fixity -instance NFData SourceUnpackedness where+instance NFData Callconv +instance NFData Foreign -instance NFData FunDep where+instance NFData SourceStrictness +instance NFData SourceUnpackedness -instance NFData Bang where+instance NFData FunDep +instance NFData Bang #if MIN_VERSION_template_haskell(2,12,0) instance NFData PatSynDir where@@ -131,48 +114,39 @@ instance NFData DerivClause where #endif -#if MIN_VERSION_template_haskell(2,22,0)+#if MIN_VERSION_template_haskell(2,21,0) instance NFData BndrVis where-instance NFData NamespaceSpecifier where #endif -instance NFData Con where---instance NFData Range where---instance NFData Clause where---instance NFData PkgName where---instance NFData Dec where---instance NFData Stmt where-+#if MIN_VERSION_template_haskell(2,22,0)+instance NFData NamespaceSpecifier where+#endif -instance NFData TyLit where+instance NFData Con +instance NFData Range -instance NFData NameSpace where+instance NFData Clause +instance NFData PkgName -instance NFData Body where+instance NFData Dec +instance NFData Stmt -instance NFData Guard where+instance NFData TyLit +instance NFData NameSpace -instance NFData Match where+instance NFData Body +instance NFData Guard -instance NFData ModName where+instance NFData Match +instance NFData ModName -instance NFData Pat where+instance NFData Pat #if MIN_VERSION_template_haskell(2,16,0) instance NFData Bytes where@@ -188,19 +162,14 @@ #endif -instance NFData NameFlavour where---instance NFData Type where---instance NFData Exp where-+instance NFData NameFlavour -instance NFData Lit where+instance NFData Type -instance NFData OccName where+instance NFData Exp +instance NFData Lit -instance NFData Name where+instance NFData OccName +instance NFData Name
bench/Models.hs view
@@ -1,13 +1,16 @@+{-# LANGUAGE TupleSections #-}+ module Models where import Data.Monoid-import Language.Haskell.TH import qualified Data.Text as Text+import Language.Haskell.TH import Database.Persist.Quasi import Database.Persist.Quasi.Internal-import Database.Persist.TH 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@@ -18,7 +21,7 @@ parseReferences' = runQ . parseReferencesQ parseReferencesQ :: String -> Q Exp-parseReferencesQ = parseReferences lowerCaseSettings . Text.pack+parseReferencesQ = parseReferences lowerCaseSettings . pure . (Nothing,) . Text.pack -- | # of models, # of fields mkModels :: Int -> Int -> String@@ -29,7 +32,7 @@ mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String mkModelsWithFieldModifier k i f =- unlines . fmap unlines . take i . map mkModel . zip [0..] . cycle $+ unlines . fmap unlines . take i . map mkModel . zip [0 ..] . cycle $ [ "Model" , "Foobar" , "User"@@ -47,13 +50,17 @@ indent i = map (replicate i ' ' ++) mkFields :: Int -> [String]-mkFields i = take i $ map mkField $ zip [0..] $ cycle- [ "Bool"- , "Int"- , "String"- , "Double"- , "Text"- ]+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
persistent.cabal view
@@ -1,220 +1,234 @@-name: persistent-version: 2.14.6.3-license: MIT-license-file: LICENSE-author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info>-synopsis: Type-safe, multi-backend data serialization.-description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent>.-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--library- build-depends:- base >= 4.11.1.0 && < 5- , aeson >= 1.0 && < 2.3- , attoparsec- , attoparsec-aeson >= 2.1.0.0 && < 2.3- , 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- , monad-logger >= 0.3.28- , mtl- , path-pieces >= 0.2- , resource-pool >= 0.2.3- , resourcet >= 1.1.10- , scientific- , silently- , template-haskell >= 2.13 && < 2.23- , text >= 1.2- , th-lift-instances >= 0.1.14 && < 0.2- , time >= 1.6- , transformers >= 0.5- , unliftio- , unliftio-core- , unordered-containers- , vault- , vector+name: persistent+version: 2.18.1.0+license: MIT+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer:+ Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info> - default-extensions:- FlexibleContexts- , MultiParamTypeClasses- , OverloadedStrings- , TypeFamilies+synopsis: Type-safe, multi-backend data serialization.+description:+ Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent>. - exposed-modules:- Database.Persist- Database.Persist.Types- Database.Persist.Names- Database.Persist.PersistValue- Database.Persist.EntityDef- Database.Persist.EntityDef.Internal- Database.Persist.FieldDef- Database.Persist.FieldDef.Internal- Database.Persist.ImplicitIdDef- Database.Persist.ImplicitIdDef.Internal- Database.Persist.TH+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 - Database.Persist.Quasi- Database.Persist.Quasi.Internal+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 - Database.Persist.Sql- Database.Persist.Sql.Migration- Database.Persist.Sql.Types.Internal- Database.Persist.Sql.Util+ default-extensions:+ FlexibleContexts+ MultiParamTypeClasses+ OverloadedStrings+ TypeFamilies - Database.Persist.SqlBackend- Database.Persist.SqlBackend.StatementCache- Database.Persist.SqlBackend.SqlPoolHooks- Database.Persist.SqlBackend.Internal- Database.Persist.SqlBackend.Internal.InsertSqlResult- Database.Persist.SqlBackend.Internal.IsolationLevel- Database.Persist.SqlBackend.Internal.SqlPoolHooks- Database.Persist.SqlBackend.Internal.Statement- Database.Persist.SqlBackend.Internal.StatementCache- Database.Persist.SqlBackend.Internal.MkSqlBackend+ 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 - Database.Persist.Class- 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 + -- 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.Types.Base-- 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.Types- Database.Persist.Compatible.TH+ Database.Persist.Compatible.TH+ Database.Persist.Compatible.Types - ghc-options: -Wall -Werror=incomplete-patterns+ ghc-options: -Wall -Werror=incomplete-patterns default-language: Haskell2010 test-suite test- type: exitcode-stdio-1.0- main-is: main.hs-- build-depends:- base >= 4.9 && < 5- , aeson- , attoparsec- , base64-bytestring- , blaze-html- , bytestring- , conduit- , containers- , deepseq- , fast-logger- , hspec >= 2.4- , http-api-data- , 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+ 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 - hs-source-dirs:- test/+ hs-source-dirs: test/ - ghc-options: -Wall+ -- 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- , TypeOperators+ 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.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- 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- , persistent- , criterion- , deepseq >= 1.4- , file-embed- , text- , template-haskell- other-modules: Models- default-language: Haskell2010+ 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
test/Database/Persist/ClassSpec.hs view
@@ -1,7 +1,7 @@ module Database.Persist.ClassSpec where -import Database.Persist.Class import Data.Time+import Database.Persist.Class import Database.Persist.Types import Test.Hspec @@ -9,7 +9,15 @@ spec = describe "Class" $ do describe "PersistField" $ do describe "UTCTime" $ do- it "fromPersistValue with format" $+ 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)))+ `shouldBe` Right+ (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123)))
test/Database/Persist/PersistValueSpec.hs view
@@ -1,16 +1,14 @@ module Database.Persist.PersistValueSpec where -import Test.Hspec-import Database.Persist.PersistValue-import Data.List.NonEmpty (NonEmpty(..), (<|))+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-import Data.Aeson-import qualified Data.ByteString.Char8 as BS8 - spec :: Spec spec = describe "PersistValueSpec" $ do describe "PersistValue" $ do@@ -18,12 +16,10 @@ let testPrefix constr prefixChar bytes = takePrefix (toJSON (constr (BS8.pack bytes)))- ===- String (T.singleton prefixChar)+ === String (T.singleton prefixChar) roundTrip constr bytes = fromJSON (toJSON (constr (BS8.pack bytes)))- ===- Data.Aeson.Success (constr (BS8.pack bytes))+ === Data.Aeson.Success (constr (BS8.pack bytes)) subject constr prefixChar = do prop ("encodes with a " ++ [prefixChar] ++ " prefix") $ testPrefix constr prefixChar
test/Database/Persist/QuasiSpec.hs view
@@ -8,1223 +8,1250 @@ import Prelude hiding (lines) import Control.Exception-import Control.Monad-import Data.List hiding (lines)-import Data.List.NonEmpty (NonEmpty(..), (<|))-import qualified Data.List.NonEmpty as NEL-import qualified Data.Map as Map-import qualified Data.Text as T-import Database.Persist.EntityDef.Internal-import Database.Persist.Quasi-import Database.Persist.Quasi.Internal-import Database.Persist.Types-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck-import Text.Shakespeare.Text (st)--spec :: Spec-spec = describe "Quasi" $ do- describe "parseEntityFields" $ do- let helloWorldTokens = Token "hello" :| [Token "world"]- foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"]- it "works" $ do- parseEntityFields []- `shouldBe`- mempty- it "works2" $ do- parseEntityFields- [ Line 0 helloWorldTokens- ]- `shouldBe`- ( [NEL.toList helloWorldTokens], mempty )- it "works3" $ do- parseEntityFields- [ Line 0 helloWorldTokens- , Line 2 foobarbazTokens- ]- `shouldBe`- ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty )- it "works4" $ do- parseEntityFields- [ Line 0 [Token "Product"]- , Line 2 (Token <$> ["name", "Text"])- , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])- ]- `shouldBe`- ( []- , Map.fromList- [ ("Product",- [ ["name", "Text"]- , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]- ]- ) ]- )- it "works5" $ do- parseEntityFields- [ Line 0 [Token "Product"]- , Line 2 (Token <$> ["name", "Text"])- , Line 4 [Token "ExtraBlock"]- , Line 4 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"])- ]- `shouldBe`- ( []- , Map.fromList- [ ("Product",- [ ["name", "Text"]- , ["ExtraBlock"]- , ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]- ]- )]- )- 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 "parseLine" $ do- it "returns nothing when line is just whitespace" $- parseLine " " `shouldBe` Nothing-- it "handles normal words" $- parseLine " foo bar baz" `shouldBe`- Just- ( Line 1- [ Token "foo"- , Token "bar"- , Token "baz"- ]- )-- it "handles numbers" $- parseLine " one (Finite 1)" `shouldBe`- Just- ( Line 2- [ Token "one"- , Token "Finite 1"- ]- )-- it "handles quotes" $- parseLine " \"foo bar\" \"baz\"" `shouldBe`- Just- ( Line 2- [ Token "foo bar"- , Token "baz"- ]- )-- it "should error if quotes are unterminated" $ do- evaluate (parseLine " \"foo bar")- `shouldErrorWithMessage`- "Unterminated quoted string starting with foo bar"-- it "handles quotes mid-token" $- parseLine " x=\"foo bar\" \"baz\"" `shouldBe`- Just- ( Line 2- [ Token "x=foo bar"- , Token "baz"- ]- )-- it "handles escaped quote mid-token" $- parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe`- Just- ( Line 2- [ Token "x=\\\"foo"- , Token "bar\""- , Token "baz"- ]- )-- it "handles unnested parantheses" $- parseLine " (foo bar) (baz)" `shouldBe`- Just- ( Line 2- [ Token "foo bar"- , Token "baz"- ]- )-- it "handles unnested parantheses mid-token" $- parseLine " x=(foo bar) (baz)" `shouldBe`- Just- ( Line 2- [ Token "x=foo bar"- , Token "baz"- ]- )-- it "handles nested parantheses" $- parseLine " (foo (bar)) (baz)" `shouldBe`- Just- ( Line 2- [ Token "foo (bar)"- , Token "baz"- ]- )-- it "escaping" $- parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe`- Just- ( Line 2- [ Token "foo (bar"- , Token "y=baz\""- ]- )-- it "mid-token quote in later token" $- parseLine "foo bar baz=(bin\")" `shouldBe`- Just- ( Line 0- [ Token "foo"- , Token "bar"- , Token "baz=bin\""- ]- )-- describe "comments" $ do- it "recognizes one line" $ do- parseLine "-- | this is a comment" `shouldBe`- Just- ( Line 0- [ DocComment "this is a comment"- ]- )- it "recognizes empty line" $ do- parseLine "-- |" `shouldBe`- Just- ( Line 0- [ DocComment ""- ]- )-- it "works if comment is indented" $ do- parseLine " -- | comment" `shouldBe`- Just (Line 2 [DocComment "comment"])-- 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] = parse lowerCaseSettings 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` ["-- | this is a bike"]- 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 the `entityForeigns` field" $ do- let [user, notification] = parse lowerCaseSettings [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-|]- 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", "-- | this is a 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] = parse lowerCaseSettings definitions- evaluate (unboundEntityDef user)- `shouldErrorWithMessage`- "Unterminated parens string starting with Maybe Int"-- it "errors on duplicate cascade update declarations" $ do- let definitions = [st|-User- age Int OnUpdateCascade OnUpdateCascade-|]- let [user] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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] =- parse (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] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) 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] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) 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] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) 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] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) 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] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) 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] =- parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) 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] = parse lowerCaseSettings 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] = parse lowerCaseSettings 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- |]-- let preparsed =- preparse subject- it "preparse works" $ do- (length <$> preparsed) `shouldBe` Just 10-- let fooLines =- [ Line- { lineIndent = 0- , tokens = Token "Foo" :| []- }- , Line- { lineIndent = 4- , tokens = Token "name" :| [Token "String"]- }- , Line- { lineIndent = 4- , tokens = Token "age" :| [Token "Int"]- }- ]- emptyLines =- [ Line- { lineIndent = 0- , tokens = Token "EmptyEntity" :| []- }- ]- barLines =- [ Line- { lineIndent = 0- , tokens = Token "Bar" :| []- }- , Line- { lineIndent = 4- , tokens = Token "name" :| [Token "String"]- }- ]- bazLines =- [ Line- { lineIndent = 0- , tokens = Token "Baz" :| []- }- , Line- { lineIndent = 4- , tokens = Token "a" :| [Token "Int"]- }- , Line- { lineIndent = 4- , tokens = Token "b" :| [Token "String"]- }- , Line- { lineIndent = 4- , tokens = Token "c" :| [Token "FooId"]- }- ]-- let- linesAssociated =- case preparsed of- Nothing -> error "preparsed failed"- Just lines -> associateLines lines- it "associateLines works" $ do- linesAssociated `shouldMatchList`- [ LinesWithComments- { lwcLines = NEL.fromList fooLines- , lwcComments = []- }- , LinesWithComments (NEL.fromList emptyLines) []- , LinesWithComments (NEL.fromList barLines) []- , LinesWithComments (NEL.fromList bazLines) []- ]-- 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 =- parse lowerCaseSettings subject- length result `shouldBe` 4-- test- [ ("Foo", 2)- , ("EmptyEntity", 0)- , ("Bar", 1)- , ("Baz", 3)- ]- result--- describe "preparse" $ do- prop "omits lines that are only whitespace" $ \len -> do- ws <- vectorOf len arbitraryWhiteSpaceChar- pure $ preparse (T.pack ws) === Nothing-- it "recognizes entity" $ do- let expected =- Line { lineIndent = 0, tokens = pure (Token "Person") } :|- [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }- , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] }- ]- preparse "Person\n name String\n age Int" `shouldBe` Just expected-- it "recognizes comments" $ do- let text = "Foo\n x X\n-- | Hello\nBar\n name String"- let expected =- Line { lineIndent = 0, tokens = pure (Token "Foo") } :|- [ Line { lineIndent = 2, tokens = Token "x" :| [Token "X"] }- , Line { lineIndent = 0, tokens = pure (DocComment "Hello") }- , Line { lineIndent = 0, tokens = pure (Token "Bar") }- , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] }- ]- preparse text `shouldBe` Just expected-- it "preparse indented" $ do- let t = T.unlines- [ " Foo"- , " x X"- , " -- | Comment"- , " -- hidden comment"- , " Bar"- , " name String"- ]- expected =- Line { lineIndent = 2, tokens = pure (Token "Foo") } :|- [ Line { lineIndent = 4, tokens = Token "x" :| [Token "X"] }- , Line { lineIndent = 2, tokens = pure (DocComment "Comment") }- , Line { lineIndent = 2, tokens = pure (Token "Bar") }- , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] }- ]- preparse t `shouldBe` Just expected-- it "preparse extra blocks" $ do- let t = T.unlines- [ "LowerCaseTable"- , " name String"- , " ExtraBlock"- , " foo bar"- , " baz"- , " ExtraBlock2"- , " something"- ]- expected =- Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|- [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] }- , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock") }- , Line { lineIndent = 4, tokens = Token "foo" :| [Token "bar"] }- , Line { lineIndent = 4, tokens = pure (Token "baz") }- , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") }- , Line { lineIndent = 4, tokens = pure (Token "something") }- ]- preparse t `shouldBe` Just expected-- it "field comments" $ do- let text = T.unlines- [ "-- | Model"- , "Foo"- , " -- | Field"- , " name String"- ]- expected =- Line { lineIndent = 0, tokens = [DocComment "Model"] } :|- [ Line { lineIndent = 0, tokens = [Token "Foo"] }- , Line { lineIndent = 2, tokens = [DocComment "Field"] }- , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) }- ]- preparse text `shouldBe` Just expected-- describe "associateLines" $ do- let foo =- Line- { lineIndent = 0- , tokens = pure (Token "Foo")- }- name'String =- Line- { lineIndent = 2- , tokens = Token "name" :| [Token "String"]- }- comment =- Line- { lineIndent = 0- , tokens = pure (DocComment "comment")- }- it "works" $ do- associateLines- ( comment :|- [ foo- , name'String- ])- `shouldBe`- [ LinesWithComments- { lwcComments = ["comment"]- , lwcLines = foo :| [name'String]- }- ]- let bar =- Line- { lineIndent = 0- , tokens = Token "Bar" :| [Token "sql", Token "=", Token "bars"]- }- age'Int =- Line- { lineIndent = 1- , tokens = Token "age" :| [Token "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 = preparse "Foo\n x X\n-- | Hello\nBar\n name String"- associateLines <$> text- `shouldBe` Just- [ LinesWithComments- { lwcLines =- Line {lineIndent = 0, tokens = Token "Foo" :| []}- :| [ Line {lineIndent = 2, tokens = Token "x" :| [Token "X"]} ]- , lwcComments =- []- }- , LinesWithComments- { lwcLines =- Line {lineIndent = 0, tokens = Token "Bar" :| []}- :| [ Line {lineIndent = 1, tokens = Token "name" :| [Token "String"]}]- , lwcComments =- ["Hello"]- }- ]- it "works with extra blocks" $ do- let text = preparse . T.unlines $- [ "LowerCaseTable"- , " Id sql=my_id"- , " fullName Text"- , " ExtraBlock"- , " foo bar"- , " baz"- , " bin"- , " ExtraBlock2"- , " something"- ]- associateLines <$> text `shouldBe` Just- [ LinesWithComments- { lwcLines =- Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|- [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }- , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }- , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }- , Line { lineIndent = 8, tokens = pure (Token "baz") }- , Line { lineIndent = 8, tokens = pure (Token "bin") }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }- , Line { lineIndent = 8, tokens = pure (Token "something") }- ]- , lwcComments = []- }- ]-- it "works with extra blocks twice" $ do- let text = 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` Just- [ LinesWithComments- { lwcLines = Line 0 (pure (Token "IdTable")) :|- [ Line 4 (Token "Id" <| Token "Day" :| [Token "default=CURRENT_DATE"])- , Line 4 (Token "name" :| [Token "Text"])- ]- , lwcComments = []- }- , LinesWithComments- { lwcLines =- Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :|- [ Line { lineIndent = 4, tokens = Token "Id" :| [Token "sql=my_id"] }- , Line { lineIndent = 4, tokens = Token "fullName" :| [Token "Text"] }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock") }- , Line { lineIndent = 8, tokens = Token "foo" :| [Token "bar"] }- , Line { lineIndent = 8, tokens = pure (Token "baz") }- , Line { lineIndent = 8, tokens = pure (Token "bin") }- , Line { lineIndent = 4, tokens = pure (Token "ExtraBlock2") }- , Line { lineIndent = 8, tokens = pure (Token "something") }- ]- , lwcComments = []- }- ]--- it "works with field comments" $ do- let text = preparse . T.unlines $- [ "-- | Model"- , "Foo"- , " -- | Field"- , " name String"- ]- associateLines <$> text `shouldBe` Just- [ LinesWithComments- { lwcLines =- Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :|- [ Line { lineIndent = 2, tokens = pure (DocComment "Field") }- , Line { lineIndent = 2, tokens = Token "name" :| [Token "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- getUnboundEntityNameHS subject `shouldBe` EntityNameHS "Foo"- describe "unboundEntityFields" $ do- let fields = unboundEntityFields subject- it "has the right field names" $ do- map unboundFieldNameHS fields `shouldMatchList`- [ FieldNameHS "name"- , FieldNameHS "age"- ]- it "has comments" $ do- map unboundFieldComments fields `shouldBe`- [ Just "Field\n"- , Nothing- ]- it "has the comments" $ do- entityComments (unboundEntityDef subject) `shouldBe`- Just "Comment\n"- it "combines extrablocks" $ do- entityExtra (unboundEntityDef subject) `shouldBe` Map.fromList- [ ("Extra", [["foo", "bar"], ["baz"]])- , ("Extra2", [["something"]])- ]- describe "works with extra blocks" $ do- let [_, lowerCaseTable, idTable] =- case 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"- , ""- ] of- [a, b, c] ->- [a, b, c] :: [UnboundEntityDef]- xs ->- error- $ "Expected 3 elements in list, got: "- <> show (length xs)- <> ", list contents: \n\n" <> intercalate "\n" (map show xs)- describe "idTable" $ do- let UnboundEntityDef { unboundEntityDef = EntityDef {..}, .. } = idTable- it "has no extra blocks" $ do- entityExtra `shouldBe` mempty- it "has the right name" $ do- entityHaskell `shouldBe` EntityNameHS "IdTable"- it "has the right fields" $ do- map unboundFieldNameHS unboundEntityFields `shouldMatchList`- [ FieldNameHS "name"- ]- describe "lowerCaseTable" $ do- let UnboundEntityDef { unboundEntityDef = EntityDef {..}, ..} = lowerCaseTable- it "has the right name" $ do- entityHaskell `shouldBe` EntityNameHS "LowerCaseTable"- it "has the right fields" $ do- map unboundFieldNameHS unboundEntityFields `shouldMatchList`- [ FieldNameHS "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"]- ]--arbitraryWhiteSpaceChar :: Gen Char-arbitraryWhiteSpaceChar =- oneof $ pure <$> [' ', '\t', '\n', '\r']+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
test/Database/Persist/TH/CommentSpec.hs view
@@ -11,7 +11,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}- {-# OPTIONS_GHC -haddock #-} module Database.Persist.TH.CommentSpec@@ -21,10 +20,12 @@ import TemplateTestImports -import Database.Persist.EntityDef.Internal (EntityDef(..))-import Database.Persist.FieldDef.Internal (FieldDef(..))+import Database.Persist.EntityDef.Internal (EntityDef (..))+import Database.Persist.FieldDef.Internal (FieldDef (..)) -mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase|+mkPersist+ (sqlSettings{mpsEntityHaddocks = True})+ [persistLowerCase| -- | Doc comments work. -- | Has multiple lines.@@ -51,10 +52,11 @@ it "has entity comments" $ do entityComments ed `shouldBe` do- Just $ mconcat- [ "Doc comments work.\n"- , "Has multiple lines.\n"- ]+ Just $+ mconcat+ [ "Doc comments work.\n"+ , "Has multiple lines.\n"+ ] describe "fieldComments" $ do let@@ -63,7 +65,8 @@ 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"- ]+ Just $+ mconcat+ [ "First line of comment on column.\n"+ , "Second line of comment on column.\n"+ ]
test/Database/Persist/TH/CompositeKeyStyleSpec.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-}- {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} module Database.Persist.TH.CompositeKeyStyleSpec where@@ -20,8 +19,9 @@ import Database.Persist.TH import Test.Hspec hiding (Selector) -mkPersist sqlSettings- [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| CompanyUserLegacyStyle companyName Text userName Text@@ -31,8 +31,9 @@ deriving instance Data CompanyUserLegacyStyle deriving instance Data (Key CompanyUserLegacyStyle) -mkPersist sqlSettings {mpsCamelCaseCompositeKeySelector = True}- [persistLowerCase|+mkPersist+ sqlSettings{mpsCamelCaseCompositeKeySelector = True}+ [persistLowerCase| CompanyUserCamelStyle companyName Text userName Text@@ -44,21 +45,21 @@ spec :: Spec spec = describe "CompositeKeyStyleSpec" $ do- describe "mpsCamelCaseCompositeKeySelector is False" $ do- it "Should generate Legacy style key selectors" $ do- let key = CompanyUserLegacyStyleKey "cName" "uName"+ 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` [ "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"- ]+ constrFields (toConstr key)+ `shouldBe` [ "companyUserCamelStyleKeyCompanyName"+ , "companyUserCamelStyleKeyUserName"+ ]
test/Database/Persist/TH/DiscoverEntitiesSpec.hs view
@@ -25,7 +25,9 @@ import Database.Persist.ImplicitIdDef import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| User name String@@ -51,10 +53,11 @@ spec :: Spec spec = describe "DiscoverEntitiesSpec" $ do- let entities = $(discoverEntities)+ let+ entities = $(discoverEntities) it "should have all three entities" $ do- entities `shouldMatchList`- [ entityDef $ Proxy @User- , entityDef $ Proxy @Dog- , entityDef $ Proxy @Cat- ]+ entities+ `shouldMatchList` [ entityDef $ Proxy @User+ , entityDef $ Proxy @Dog+ , entityDef $ Proxy @Cat+ ]
test/Database/Persist/TH/EmbedSpec.hs view
@@ -16,18 +16,19 @@ import TemplateTestImports -import Data.Text (Text) 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-import Database.Persist.Types-import Database.Persist.EntityDef-import Database.Persist.EntityDef.Internal (toEmbedEntityDef) -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| Thing name String@@ -80,12 +81,10 @@ getEntityFields edef it "has the right type" $ do fieldType fieldDef- `shouldBe`- FTList (FTTypeCon Nothing "Text")+ `shouldBe` FTList (FTTypeCon Nothing "Text") it "has the right sqltype" $ do fieldSqlType fieldDef- `shouldBe`- SqlString+ `shouldBe` SqlString describe "MapIdValue" $ do let edef =@@ -94,20 +93,15 @@ 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"- )- )+ `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+ `shouldBe` SqlString describe "HasMap" $ do let edef =@@ -116,17 +110,13 @@ 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"- )+ `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+ `shouldBe` SqlString describe "SomeThing" $ do let@@ -138,12 +128,12 @@ toEmbedEntityDef edef it "should have the same field count as Haskell fields" $ do length (embeddedFields embedDef)- `shouldBe`- length (getEntityFields edef)+ `shouldBe` length (getEntityFields edef) describe "EmbedThing" $ do it "generates the right constructor" $ do- let embedThing :: EmbedThing+ let+ embedThing :: EmbedThing embedThing = EmbedThing (Thing "asdf") pass @@ -156,14 +146,11 @@ [nameField, selfField] = getEntityFields edef it "has self reference" $ do fieldReference selfField- `shouldBe`- NoReference+ `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)-+ `shouldBe` length (embeddedFields embedDef)
test/Database/Persist/TH/ForeignRefSpec.hs view
@@ -1,4 +1,11 @@ {-# LANGUAGE DataKinds #-}+--+-- DeriveAnyClass is not actually used by persistent-template+-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving+-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.+-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.+-- See https://github.com/yesodweb/persistent/issues/578+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-}@@ -13,21 +20,14 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}------ DeriveAnyClass is not actually used by persistent-template--- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving--- This was fixed by using DerivingStrategies to specify newtype deriving should be used.--- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.--- See https://github.com/yesodweb/persistent/issues/578-{-# LANGUAGE DeriveAnyClass #-} module Database.Persist.TH.ForeignRefSpec where -import Control.Applicative (Const(..))+import Control.Applicative (Const (..)) import Data.Aeson import Data.ByteString.Lazy.Char8 () import Data.Coerce-import Data.Functor.Identity (Identity(..))+import Data.Functor.Identity (Identity (..)) import Data.Int import qualified Data.List as List import Data.Proxy@@ -45,7 +45,9 @@ import Database.Persist.TH import TemplateTestImports -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| HasCustomName sql=custom_name name Text@@ -79,6 +81,14 @@ name Text parent ParentImplicitId OnDeleteCascade OnUpdateCascade +ChildImplicitUnspecified+ name Text+ parent ParentImplicitId++ChildImplicitNoAction+ name Text+ parent ParentImplicitId OnDeleteNoAction OnUpdateNoAction+ ParentExplicit name Text Primary name@@ -86,6 +96,14 @@ 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@@ -96,8 +114,7 @@ entityDef $ Proxy @HasCustomName it "should have a custom db name" $ do entityDB edef- `shouldBe`- EntityNameDB "custom_name"+ `shouldBe` EntityNameDB "custom_name" it "should compile" $ do True `shouldBe` True@@ -110,9 +127,108 @@ entityForeigns fpsDef it "has the right type" $ do foreignPrimarySourceFk_name_target (ForeignPrimarySource "asdf")- `shouldBe`- ForeignPrimaryKey "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@@ -123,34 +239,37 @@ childForeigns = entityForeigns childDef it "should have a single foreign reference defined" $ do- case entityForeigns childDef of- [a] ->- pure ()- as ->- expectationFailure . mconcat $- [ "Expected one foreign reference on childDef, "- , "got: "- , show as- ]+ case entityForeigns childDef of+ [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 {..}] =+ [ForeignDef{..}] = childForeigns describe "ChildExplicit" $ do it "should have the right target table" $ do- foreignRefTableHaskell `shouldBe`- EntityNameHS "ParentExplicit"- foreignRefTableDBName `shouldBe`- EntityNameDB "parent_explicit"+ foreignRefTableHaskell+ `shouldBe` EntityNameHS "ParentExplicit"+ foreignRefTableDBName+ `shouldBe` EntityNameDB "parent_explicit" it "should have the right cascade behavior" $ do foreignFieldCascade- `shouldBe`- FieldCascade- { fcOnUpdate =- Just Cascade- , fcOnDelete =- Just Cascade- }+ `shouldBe` FieldCascade+ { fcOnUpdate =+ Just Cascade+ , fcOnDelete =+ Just Cascade+ } it "is not nullable" $ do foreignNullable `shouldBe` False it "is to the Primary key" $ do@@ -168,11 +287,16 @@ case childFields of [nameField, parentIdField] -> do it "parentId has reference" $ do- fieldReference parentIdField `shouldBe`- ForeignRef (EntityNameHS "ParentImplicit")+ fieldReference parentIdField+ `shouldBe` ForeignRef (EntityNameHS "ParentImplicit")+ fieldCascade parentIdField+ `shouldBe` FieldCascade+ { fcOnUpdate = Just Cascade+ , fcOnDelete = Just Cascade+ } as -> error . mconcat $- [ "Expected one foreign reference on childDef, "+ [ "(Implicit) Expected one foreign reference on childDef, " , "got: " , show as ]
test/Database/Persist/TH/ImplicitIdColSpec.hs view
@@ -24,11 +24,13 @@ do let uuidDef =- mkImplicitIdDef @Text "uuid_generate_v1mc()"+ mkImplicitIdDef @Text "uuid_generate_v1mc()" settings = setImplicitIdDef uuidDef sqlSettings - mkPersist settings [persistLowerCase|+ mkPersist+ settings+ [persistLowerCase| User name String@@ -60,5 +62,4 @@ it "has Text FieldType" $ asIO $ do pendingWith "currently returns UserId, may not be an issue" fieldType idField- `shouldBe`- fieldTypeFromTypeable @Text+ `shouldBe` fieldTypeFromTypeable @Text
test/Database/Persist/TH/JsonEncodingSpec.hs view
@@ -29,7 +29,9 @@ import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) import Database.Persist.Types -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| JsonEncoding json name Text age Int@@ -71,58 +73,54 @@ 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 $+ `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+ `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"+ `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+ `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)- ]+ `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+ Entity key j decode (encode ent)- `shouldBe`- Just ent+ `shouldBe` Just ent prop "works with a composite key" $ \j@JsonEncoding2{..} -> do let@@ -130,10 +128,9 @@ ent = Entity key j toJSON ent- `shouldBe`- object- [ ("name", toJSON jsonEncoding2Name)- , ("age", toJSON jsonEncoding2Age)- , ("blood", toJSON jsonEncoding2Blood)- , ("id", toJSON key)- ]+ `shouldBe` object+ [ ("name", toJSON jsonEncoding2Name)+ , ("age", toJSON jsonEncoding2Age)+ , ("blood", toJSON jsonEncoding2Blood)+ , ("id", toJSON key)+ ]
test/Database/Persist/TH/KindEntitiesSpec.hs view
@@ -14,7 +14,9 @@ import Database.Persist.TH.KindEntitiesSpecImports import TemplateTestImports -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| Customer name String@@ -28,7 +30,9 @@ spec :: Spec spec = describe "KindEntities" $ do it "should support DataKinds in entity definition" $ do- let mkTransfer :: CustomerId -> MoneyAmount 'CustomerOwned 'Debit -> CustomerTransfer+ let+ mkTransfer+ :: CustomerId -> MoneyAmount 'CustomerOwned 'Debit -> CustomerTransfer mkTransfer = CustomerTransfer getAmount :: CustomerTransfer -> MoneyAmount 'CustomerOwned 'Debit getAmount = customerTransferMoneyAmount
test/Database/Persist/TH/MaybeFieldDefsSpec.hs view
@@ -13,7 +13,9 @@ import TemplateTestImports -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| Account name (Maybe String) email String@@ -22,7 +24,8 @@ spec :: Spec spec = describe "MaybeFieldDefs" $ do it "should support literal `Maybe` declaration in entity definition" $ do- let mkAccount :: Maybe String -> String -> Account+ let+ mkAccount :: Maybe String -> String -> Account mkAccount = Account compiles
test/Database/Persist/TH/MigrationOnlySpec.hs view
@@ -22,7 +22,9 @@ import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) import Database.Persist.Types -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| HasMigrationOnly name String@@ -54,12 +56,8 @@ describe "toPersistFields" $ do it "should have one field" $ do map toPersistValue (toPersistFields (HasMigrationOnly "asdf"))- `shouldBe`- [PersistText ("asdf" :: Text)]+ `shouldBe` [PersistText ("asdf" :: Text)] describe "fromPersistValues" $ do it "should work with only item in list" $ do fromPersistValues [PersistText "Hello"]- `shouldBe`- Right (HasMigrationOnly "Hello")--+ `shouldBe` Right (HasMigrationOnly "Hello")
test/Database/Persist/TH/MultiBlockSpec.hs view
@@ -18,7 +18,6 @@ import TemplateTestImports - import Database.Persist.TH.MultiBlockSpec.Model share@@ -56,24 +55,20 @@ getEntityFields edef it "User reference works" $ do fieldReference userRef- `shouldBe`- ForeignRef- (EntityNameHS "User")+ `shouldBe` ForeignRef+ (EntityNameHS "User") it "Primary key reference works" $ do fieldReference profileRef- `shouldBe`- ForeignRef- (EntityNameHS "MBDog")+ `shouldBe` ForeignRef+ (EntityNameHS "MBDog") it "Thing ref works (same block)" $ do fieldReference thingRef- `shouldBe`- ForeignRef- (EntityNameHS "Thing")+ `shouldBe` ForeignRef+ (EntityNameHS "Thing") it "ThingAuto ref works (same block)" $ do fieldReference thingAutoRef- `shouldBe`- ForeignRef- (EntityNameHS "ThingAuto")+ `shouldBe` ForeignRef+ (EntityNameHS "ThingAuto")
test/Database/Persist/TH/MultiBlockSpec/Model.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -42,4 +42,3 @@ Primary name age |]-
test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -Wno-unused-local-binds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-}@@ -9,6 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-local-binds #-} module Database.Persist.TH.NestedSymbolsInTypeSpec where @@ -16,7 +16,9 @@ import Database.Persist.TH.NestedSymbolsInTypeSpecImports import TemplateTestImports -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| PathEntitySimple readOnly (Maybe (SomePath ReadOnly)) @@ -27,16 +29,19 @@ spec :: Spec spec = describe "NestedSymbolsInType" $ do it "should support nested parens" $ do- let mkPathEntitySimple :: Maybe (SomePath ReadOnly) -> PathEntitySimple+ 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+ let+ mkPathEntityNested :: Maybe (Map Text [SomePath ReadWrite]) -> PathEntityNested mkPathEntityNested = PathEntityNested- pathEntityNestedPaths' :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite])+ pathEntityNestedPaths'+ :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite]) pathEntityNestedPaths' = pathEntityNestedPaths compiles
test/Database/Persist/TH/NoFieldSelectorsSpec.hs view
@@ -3,15 +3,15 @@ {-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE DuplicateRecordFields #-} #endif-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-} module Database.Persist.TH.NoFieldSelectorsSpec where
test/Database/Persist/TH/OverloadedLabelSpec.hs view
@@ -12,14 +12,15 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}- {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} module Database.Persist.TH.OverloadedLabelSpec where import TemplateTestImports -mkPersist sqlSettings [persistUpperCase|+mkPersist+ sqlSettings+ [persistUpperCase| User name String@@ -42,14 +43,16 @@ spec :: Spec spec = describe "OverloadedLabels" $ do it "works for monomorphic labels" $ do- let UserName = #name+ let+ UserName = #name OrganizationName = #name DogName = #name compiles it "works for polymorphic labels" $ do- let name :: _ => EntityField rec a+ let+ name :: (_) => EntityField rec a name = #name UserName = name@@ -59,13 +62,15 @@ compiles it "works for id labels" $ do- let UserId = #id+ let+ UserId = #id orgId = #id :: EntityField Organization OrganizationId compiles it "works for Primary labels" $ do- let StudentId = #id+ let+ StudentId = #id studentId = #id :: EntityField Student StudentId compiles
test/Database/Persist/TH/PersistWith/Model.hs view
@@ -18,7 +18,10 @@ import Database.Persist.TH.PersistWith.Model2 as Model2 -mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|+mkPersistWith+ sqlSettings+ $(discoverEntities)+ [persistLowerCase| IceCream flavor FlavorId
test/Database/Persist/TH/PersistWith/Model2.hs view
@@ -16,7 +16,9 @@ import TemplateTestImports -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| Flavor name Text
test/Database/Persist/TH/PersistWithSpec.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}@@ -16,11 +16,14 @@ module Database.Persist.TH.PersistWithSpec where import Control.Monad-import TemplateTestImports import Database.Persist.TH.PersistWith.Model as Model (IceCream, IceCreamId) import Language.Haskell.TH as TH+import TemplateTestImports -mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|+mkPersistWith+ sqlSettings+ $(discoverEntities)+ [persistLowerCase| BestTopping iceCream IceCreamId@@ -62,11 +65,17 @@ 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- ]+ 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)
test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs view
@@ -18,7 +18,9 @@ -- always explicitly import qualified Hspec in the context of this spec import qualified Test.Hspec as HS -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| Plain name String age Int@@ -34,12 +36,14 @@ spec = HS.describe "RequireOnlyPersistImport" $ do HS.it "Plain" $ do- let typeSigPlain :: String -> Int -> Plain+ let+ typeSigPlain :: String -> Int -> Plain typeSigPlain = Plain compiles HS.it "JsonEncoded" $ do- let typeSigJsonEncoded :: String -> Int -> JsonEncoded+ let+ typeSigJsonEncoded :: String -> Int -> JsonEncoded typeSigJsonEncoded = JsonEncoded compiles
@@ -1,32 +1,37 @@-{-# LANGUAGE TypeApplications, DeriveGeneric #-}-{-# LANGUAGE DataKinds, ExistentialQuantification #-}+{-# 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 #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE StandaloneDeriving #-} module Database.Persist.TH.SharedPrimaryKeyImportedSpec where import TemplateTestImports +import Control.Monad.IO.Class import Data.Proxy-import Test.Hspec import Database.Persist import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH import Language.Haskell.TH-import Control.Monad.IO.Class+import Test.Hspec import Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) -mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase|+mkPersistWith+ sqlSettings+ $(discoverEntities)+ [persistLowerCase| ProfileX Id UserId@@ -39,17 +44,15 @@ -- 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)+ `shouldBe` sqlType (Proxy @ProfileXId) describe "getEntityId FieldDef" $ do it "should match underlying primary key" $ do let- getSqlType :: PersistEntity a => Proxy a -> SqlType+ getSqlType :: (PersistEntity a) => Proxy a -> SqlType getSqlType p = case getEntityId (entityDef p) of EntityIdField fd ->@@ -57,9 +60,7 @@ _ -> SqlOther "Composite Key" getSqlType (Proxy @User)- `shouldBe`- getSqlType (Proxy @ProfileX)-+ `shouldBe` getSqlType (Proxy @ProfileX) describe "foreign reference should work" $ do it "should have a foreign reference" $ do@@ -68,5 +69,4 @@ Just fd = getEntityIdField (entityDef (Proxy @ProfileX)) fieldReference fd- `shouldBe`- ForeignRef (EntityNameHS "User")+ `shouldBe` ForeignRef (EntityNameHS "User")
@@ -1,30 +1,34 @@-{-# LANGUAGE TypeApplications, DeriveGeneric #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DataKinds, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE StandaloneDeriving #-} module Database.Persist.TH.SharedPrimaryKeySpec where import TemplateTestImports -import Data.Time import Data.Proxy-import Test.Hspec+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|+share+ [mkPersist sqlSettings]+ [persistLowerCase| User name String@@ -49,7 +53,7 @@ spec :: Spec spec = describe "Shared Primary Keys" $ do let- getSqlType :: PersistEntity a => Proxy a -> SqlType+ getSqlType :: (PersistEntity a) => Proxy a -> SqlType getSqlType p = case getEntityId (entityDef p) of EntityIdField fd ->@@ -77,49 +81,42 @@ describe "PersistFieldSql" $ do it "should match underlying key" $ do sqlType (Proxy @UserId)- `shouldBe`- sqlType (Proxy @ProfileId)+ `shouldBe` sqlType (Proxy @ProfileId) describe "User" $ do it "has default ID key, SqlInt64" $ do sqlType (Proxy @UserId)- `shouldBe`- SqlInt64+ `shouldBe` SqlInt64 testSqlTypeEquivalent (Proxy @User) - describe "Profile" $ do+ describe "Profile" $ do it "has same ID key type as User" $ do sqlType (Proxy @ProfileId)- `shouldBe`- sqlType (Proxy @UserId)- testSqlTypeEquivalent(Proxy @Profile)+ `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)+ `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)+ `shouldBe` getSqlType (Proxy @Profile) describe "DayKeyTable" $ do testSqlTypeEquivalent (Proxy @DayKeyTable) it "sqlType has Day type" $ do sqlType (Proxy @Day)- `shouldBe`- sqlType (Proxy @DayKeyTableId)+ `shouldBe` sqlType (Proxy @DayKeyTableId) it "getSqlType has Day type" $ do sqlType (Proxy @Day)- `shouldBe`- getSqlType (Proxy @DayKeyTable)+ `shouldBe` getSqlType (Proxy @DayKeyTable) describe "RefDayKey" $ do let@@ -129,13 +126,11 @@ it "has same sqltype as underlying" $ do fieldSqlType dayKeyField- `shouldBe`- sqlType (Proxy @Day)+ `shouldBe` sqlType (Proxy @Day) it "has the right fieldType" $ do fieldType dayKeyField- `shouldBe`- FTTypeCon Nothing "DayKeyTableId"+ `shouldBe` FTTypeCon Nothing "DayKeyTableId" it "has the right type" $ do let
test/Database/Persist/TH/SumSpec.hs view
@@ -18,7 +18,6 @@ import TemplateTestImports - import Database.Persist.TH.MultiBlockSpec.Model share@@ -40,4 +39,3 @@ spec :: Spec spec = do it "should warn" True-
test/Database/Persist/TH/ToFromPersistValuesSpec.hs view
@@ -1,4 +1,11 @@-{-# LANGUAGE DataKinds, ScopedTypeVariables #-}+{-# 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 #-}@@ -8,40 +15,36 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}------ DeriveAnyClass is not actually used by persistent-template--- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving--- This was fixed by using DerivingStrategies to specify newtype deriving should be used.--- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.--- See https://github.com/yesodweb/persistent/issues/578-{-# LANGUAGE DeriveAnyClass #-} module Database.Persist.TH.ToFromPersistValuesSpec where import TemplateTestImports -import Database.Persist.Sql.Util-import Database.Persist.Class.PersistEntity-import Data.List.NonEmpty (NonEmpty(..))+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+instance (PersistFieldSql a) => PersistFieldSql (NonEmpty a) where sqlType _ = SqlString -instance PersistField a => PersistField (NonEmpty a) where+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)+ (l : ls) -> Right (l :| ls) -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| NormalModel name Text@@ -77,7 +80,7 @@ spec = describe "{to,from}PersistValues" $ do let toPersistValues- :: PersistEntity rec => rec -> [PersistValue]+ :: (PersistEntity rec) => rec -> [PersistValue] toPersistValues = map toPersistValue . toPersistFields @@ -89,12 +92,10 @@ subject model fields = do it "toPersistValues" $ do toPersistValues model- `shouldBe`- fields+ `shouldBe` fields it "fromPersistValues" $ do fromPersistValues fields- `shouldBe`- Right model+ `shouldBe` Right model describe "NormalModel" $ do subject (NormalModel "hello" 30)@@ -120,36 +121,33 @@ describe "NormalModel" $ do it "has all values" $ do mkInsertValues (NormalModel "hello" 30)- `shouldBe`- [ PersistText "hello"- , PersistInt64 30- ]+ `shouldBe` [ PersistText "hello"+ , PersistInt64 30+ ] describe "PrimaryModel" $ do it "has all values" $ do mkInsertValues (PrimaryModel "hello" 30)- `shouldBe`- [ PersistText "hello"- , PersistInt64 30- ]+ `shouldBe` [ PersistText "hello"+ , PersistInt64 30+ ] describe "IsMigrationOnly" $ do it "has all values" $ do mkInsertValues (IsMigrationOnly "hello" 30)- `shouldBe`- [ PersistText "hello"- , PersistInt64 30- ]+ `shouldBe` [ PersistText "hello"+ , PersistInt64 30+ ] describe "parseEntityValues" $ do let subject- :: forall rec. (PersistEntity rec, Show rec, Eq rec)+ :: 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+ `shouldBe` Right rec describe "NormalModel" $ do subject [ PersistInt64 20@@ -188,21 +186,20 @@ describe "entityValues" $ do let subject- :: forall rec. (PersistEntity rec, Show rec, Eq rec)+ :: forall rec+ . (PersistEntity rec, Show rec, Eq rec) => [PersistValue] -> Entity rec -> Spec subject pvals entity = do- it "renders as you would expect"$ do+ it "renders as you would expect" $ do entityValues entity- `shouldBe`- pvals+ `shouldBe` pvals it "round trips with parseEntityValues" $ do parseEntityValues (entityDef $ Proxy @rec) (entityValues entity)- `shouldBe`- Right entity+ `shouldBe` Right entity describe "NormalModel" $ do subject [ PersistInt64 10
test/Database/Persist/TH/TypeLitFieldDefsSpec.hs view
@@ -33,7 +33,9 @@ instance PersistFieldSql (Labelled n) where sqlType _ = sqlType (Proxy :: Proxy Int) -mkPersist sqlSettings [persistLowerCase|+mkPersist+ sqlSettings+ [persistLowerCase| WithFinite one (Finite 1) twenty (Finite 20)@@ -46,12 +48,14 @@ spec :: Spec spec = describe "TypeLitFieldDefs" $ do it "should support numeric type literal fields in entity definition" $ do- let mkFinite :: Finite 1 -> Finite 20 -> WithFinite+ 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+ let+ mkLabelled :: Labelled "one" -> Labelled "twenty" -> WithLabelled mkLabelled = WithLabelled compiles
test/Database/Persist/THSpec.hs view
@@ -1,4 +1,11 @@ {-# LANGUAGE DataKinds #-}+--+-- DeriveAnyClass is not actually used by persistent-template+-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving+-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.+-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.+-- See https://github.com/yesodweb/persistent/issues/578+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-}@@ -14,27 +21,21 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}------ DeriveAnyClass is not actually used by persistent-template--- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving--- This was fixed by using DerivingStrategies to specify newtype deriving should be used.--- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.--- See https://github.com/yesodweb/persistent/issues/578-{-# LANGUAGE DeriveAnyClass #-} module Database.Persist.THSpec where -import Control.Applicative (Const(..))+import Control.Applicative (Const (..)) import Data.Aeson (decode, encode) import Data.ByteString.Lazy.Char8 () import Data.Coerce-import Data.Functor.Identity (Identity(..))+import Data.Functor.Identity (Identity (..)) import Data.Int import qualified Data.List as List import Data.Proxy 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@@ -43,12 +44,13 @@ 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@@ -76,8 +78,18 @@ -- machinery type TextId = Text -share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase|+-- | 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@@ -108,7 +120,14 @@ |] -mkPersist sqlSettings [persistLowerCase|+-- | 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@@ -163,7 +182,9 @@ |] -share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase|+share+ [mkPersist sqlSettings{mpsGeneric = False, mpsGenerateLenses = True}]+ [persistLowerCase| Lperson json name Text age Int Maybe@@ -212,14 +233,16 @@ EntityHaddockSpec.spec CompositeKeyStyleSpec.spec it "QualifiedReference" $ do- let ed = entityDef @QualifiedReference Proxy- [FieldDef {..}] = entityFields ed+ 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{..} =+ 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@@ -229,10 +252,10 @@ -- -- should behave like an implicit id column. (TestDefaultKeyColKey (SqlBackendKey 32) :: Key TestDefaultKeyCol)- `shouldBe`- (toSqlKey 32 :: Key TestDefaultKeyCol)+ `shouldBe` (toSqlKey 32 :: Key TestDefaultKeyCol) describe "HasDefaultId" $ do- let EntityIdField FieldDef{..} =+ let+ EntityIdField FieldDef{..} = entityId (entityDef (Proxy @HasDefaultId)) it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id"@@ -246,7 +269,8 @@ fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId" describe "HasCustomSqlId" $ do- let EntityIdField FieldDef{..} =+ let+ EntityIdField FieldDef{..} = entityId (entityDef (Proxy @HasCustomSqlId)) it "should have custom db name" $ do fieldDB `shouldBe` FieldNameDB "my_id"@@ -257,7 +281,8 @@ it "should have correct haskell type" $ do fieldType `shouldBe` FTTypeCon Nothing "String" describe "HasIdDef" $ do- let EntityIdField FieldDef{..} =+ let+ EntityIdField FieldDef{..} = entityId (entityDef (Proxy @HasIdDef)) it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id"@@ -269,7 +294,8 @@ fieldType `shouldBe` FTTypeCon Nothing "Int" describe "SharedPrimaryKey" $ do- let sharedDef = entityDef (Proxy @SharedPrimaryKey)+ let+ sharedDef = entityDef (Proxy @SharedPrimaryKey) EntityIdField FieldDef{..} = entityId sharedDef it "should have usual db name" $ do@@ -284,19 +310,17 @@ fieldType `shouldBe` (FTTypeCon Nothing "HasDefaultIdId") it "should have correct sql type from PersistFieldSql" $ do sqlType (Proxy @SharedPrimaryKeyId)- `shouldBe`- SqlInt64+ `shouldBe` SqlInt64 it "should have same sqlType as underlying record" $ do sqlType (Proxy @SharedPrimaryKeyId)- `shouldBe`- sqlType (Proxy @HasDefaultIdId)+ `shouldBe` sqlType (Proxy @HasDefaultIdId) it "should be a coercible newtype" $ do coerce @Int64 3- `shouldBe`- SharedPrimaryKeyKey (toSqlKey 3)+ `shouldBe` SharedPrimaryKeyKey (toSqlKey 3) describe "SharedPrimaryKeyWithCascade" $ do- let EntityIdField FieldDef{..} =+ let+ EntityIdField FieldDef{..} = entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade)) it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id"@@ -306,17 +330,17 @@ fieldSqlType `shouldBe` SqlInt64 it "should have correct haskell type" $ do fieldType- `shouldBe`- FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId")+ `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") it "should have cascade in field def" $ do- fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade }+ fieldCascade `shouldBe` noCascade{fcOnDelete = Just Cascade} describe "OnCascadeDelete" $ do- let subject :: FieldDef+ let+ subject :: FieldDef Just subject =- List.find ((FieldNameHS "person" ==) . fieldHaskell)- $ entityFields- $ simpleCascadeDef+ List.find ((FieldNameHS "person" ==) . fieldHaskell) $+ entityFields $+ simpleCascadeDef simpleCascadeDef = entityDef (Proxy :: Proxy HasSimpleCascadeRef) expected =@@ -325,14 +349,20 @@ , 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+ `shouldBe` EntityDef+ { entityHaskell = EntityNameHS "HasSimpleCascadeRef"+ , entityDB = EntityNameDB "HasSimpleCascadeRef"+ , entityId =+ EntityIdField+ FieldDef { fieldHaskell = FieldNameHS "Id" , fieldDB = FieldNameDB "id" , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId"@@ -346,93 +376,96 @@ , 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- }+ , 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+ `shouldBe` mempty describe "hasNaturalKey" $ do- let subject :: PersistEntity a => Proxy a -> Bool+ let+ subject :: (PersistEntity a) => Proxy a -> Bool subject p = hasNaturalKey (entityDef p) it "is True for Primary keyword" $ do subject (Proxy @HasPrimaryDef)- `shouldBe`- True+ `shouldBe` True it "is True for multiple Primary columns " $ do subject (Proxy @HasMultipleColPrimaryDef)- `shouldBe`- True+ `shouldBe` True it "is False for Id keyword" $ do subject (Proxy @HasIdDef)- `shouldBe`- False+ `shouldBe` False it "is False for unspecified/default id" $ do subject (Proxy @HasDefaultId)- `shouldBe`- False+ `shouldBe` False describe "hasCompositePrimaryKey" $ do- let subject :: PersistEntity a => Proxy a -> Bool+ 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+ `shouldBe` False it "is True for multiple Primary columns " $ do subject (Proxy @HasMultipleColPrimaryDef)- `shouldBe`- True+ `shouldBe` True it "is False for Id keyword" $ do subject (Proxy @HasIdDef)- `shouldBe`- False+ `shouldBe` False it "is False for unspecified/default id" $ do subject (Proxy @HasDefaultId)- `shouldBe`- False+ `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)+ 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+ 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))+ 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"+ let+ street1 = "street1" city1 = "city1" city2 = "city2" zip1 = Just 12345@@ -447,12 +480,16 @@ (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+ 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+ show (CustomPrimaryKeyKey 0)+ `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}"+ read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0 describe "tabulateEntityA" $ do it "works" $ do@@ -467,20 +504,25 @@ _ <- lookupEnv "PERSON_FOO" :: IO (Maybe String) pure Bar PersonAddress ->- pure $ Address "lol no" "Denver" Nothing+ 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- }+ 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@@ -495,28 +537,33 @@ "Denver" AddressZip -> Nothing- addressTabulate `shouldBe`- Entity (toSqlKey 123) Address- { 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+ 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+(^.)+ :: 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+(.~)+ :: ((a -> Identity b) -> (s -> Identity t))+ -> b+ -> s+ -> t lens .~ val = runIdentity . lens (\_ -> Identity val)
test/TemplateTestImports.hs view
@@ -10,15 +10,15 @@ import Data.Aeson.TH import Test.QuickCheck +import Control.Monad import Data.Int as X-import Database.Persist.Sql as X-import Database.Persist.TH as X-import Test.Hspec as X+import Data.Maybe import Data.Proxy as X import Data.Text as X (Text)-import Data.Maybe-import Control.Monad+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)
test/main.hs view
@@ -12,5 +12,6 @@ describe "Database" $ describe "Persist" $ do THSpec.spec QuasiSpec.spec+ QuasiSpec.warningSpecs ClassSpec.spec PersistValueSpec.spec