persistent-2.14.6.0/Database/0000755000000000000000000000000014476403105014040 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/0000755000000000000000000000000014507124116015466 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Class/0000755000000000000000000000000014507117603016536 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Compatible/0000755000000000000000000000000014507117603017550 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/EntityDef/0000755000000000000000000000000014476403105017364 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/FieldDef/0000755000000000000000000000000014476403105017133 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/ImplicitIdDef/0000755000000000000000000000000014476403105020137 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Quasi/0000755000000000000000000000000014507117603016553 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Sql/0000755000000000000000000000000014507117603016230 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Sql/Orphan/0000755000000000000000000000000014507117603017457 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Sql/Types/0000755000000000000000000000000014476403105017334 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/SqlBackend/0000755000000000000000000000000014476403105017500 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/0000755000000000000000000000000014476403105021254 5ustar0000000000000000persistent-2.14.6.0/Database/Persist/Types/0000755000000000000000000000000014507124116016572 5ustar0000000000000000persistent-2.14.6.0/bench/0000755000000000000000000000000014476403105013413 5ustar0000000000000000persistent-2.14.6.0/test/0000755000000000000000000000000014476403105013313 5ustar0000000000000000persistent-2.14.6.0/test/Database/0000755000000000000000000000000014476403105015017 5ustar0000000000000000persistent-2.14.6.0/test/Database/Persist/0000755000000000000000000000000014507124116016445 5ustar0000000000000000persistent-2.14.6.0/test/Database/Persist/TH/0000755000000000000000000000000014507117603016763 5ustar0000000000000000persistent-2.14.6.0/test/Database/Persist/TH/MultiBlockSpec/0000755000000000000000000000000014476403105021643 5ustar0000000000000000persistent-2.14.6.0/test/Database/Persist/TH/PersistWith/0000755000000000000000000000000014476403105021250 5ustar0000000000000000persistent-2.14.6.0/Database/Persist.hs0000644000000000000000000003001714476403105016026 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} -- | Welcome to @persistent@! -- -- This library intends to provide an easy, flexible, and convenient interface -- to various data storage backends. Backends include SQL databases, like -- @mysql@, @postgresql@, and @sqlite@, as well as NoSQL databases, like -- @mongodb@ and @redis@. -- -- If you intend on using a SQL database, then check out "Database.Persist.Sql". module Database.Persist ( -- * 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. -- ** 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'. module Database.Persist.Class -- * Types -- | This module re-export contains a lot of the important types for -- working with @persistent@ datatypes and underlying values. , module Database.Persist.Types -- * Query Operators -- | A convention that @persistent@ tries to follow is that operators on -- Database types correspond to a Haskell (or database) operator with a @.@ -- character at the end. So to do @a || b@ , you'd write @a '||.' b@. To -- ** Query update combinators -- | These operations are used when performing updates against the database. -- Functions like 'upsert' use them to provide new or modified values. , (=.), (+=.), (-=.), (*=.), (/=.) -- ** Query filter combinators -- | These functions are useful in the 'PersistQuery' class, like -- 'selectList', 'updateWhere', etc. , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.) -- * JSON Utilities , listToJSON , mapToJSON , toJsonText , getPersistMap -- * Other utilities , limitOffsetOrder ) where 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) infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v -- | Assign a field a value. -- -- === Examples -- -- @ -- updateAge :: MonadIO m => ReaderT SqlBackend m () -- updateAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge =. 45] -- @ -- -- Similar to `updateWhere` which is shown in the above example you can use other functions present in the module "Database.Persist.Class". Note that the first parameter of `updateWhere` is [`Filter` val] and second parameter is [`Update` val]. By comparing this with the type of `==.` and `=.`, you can see that they match up in the above usage. -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 -> 45| -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ f =. a = Update f a Assign -- | Assign a field by addition (@+=@). -- -- === Examples -- -- @ -- addAge :: MonadIO m => ReaderT SqlBackend m () -- addAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge +=. 1] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+---------+ -- > |id |name |age | -- > +-----+-----+---------+ -- > |1 |SPJ |40 -> 41 | -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ f +=. a = Update f a Add -- | Assign a field by subtraction (@-=@). -- -- === Examples -- -- @ -- subtractAge :: MonadIO m => ReaderT SqlBackend m () -- subtractAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge -=. 1] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+---------+ -- > |id |name |age | -- > +-----+-----+---------+ -- > |1 |SPJ |40 -> 39 | -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ f -=. a = Update f a Subtract -- | Assign a field by multiplication (@*=@). -- -- === Examples -- -- @ -- multiplyAge :: MonadIO m => ReaderT SqlBackend m () -- multiplyAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge *=. 2] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 -> 80| -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ f *=. a = Update f a Multiply -- | Assign a field by division (@/=@). -- -- === Examples -- -- @ -- divideAge :: MonadIO m => ReaderT SqlBackend m () -- divideAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge /=. 2] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+---------+ -- > |id |name |age | -- > +-----+-----+---------+ -- > |1 |SPJ |40 -> 20 | -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ f /=. a = Update f a Divide infix 4 ==., <., <=., >., >=., !=. (==.), (!=.), (<.), (<=.), (>.), (>=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Filter v -- | Check for equality. -- -- === Examples -- -- @ -- selectSPJ :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSPJ = selectList [UserName ==. \"SPJ\" ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f ==. a = Filter f (FilterValue a) Eq -- | Non-equality check. -- -- === Examples -- -- @ -- selectSimon :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSimon = selectList [UserName !=. \"SPJ\" ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f !=. a = Filter f (FilterValue a) Ne -- | Less-than check. -- -- === Examples -- -- @ -- selectLessAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectLessAge = selectList [UserAge <. 41 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f <. a = Filter f (FilterValue a) Lt -- | Less-than or equal check. -- -- === Examples -- -- @ -- selectLessEqualAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectLessEqualAge = selectList [UserAge <=. 40 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f <=. a = Filter f (FilterValue a) Le -- | Greater-than check. -- -- === Examples -- -- @ -- selectGreaterAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectGreaterAge = selectList [UserAge >. 40 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f >. a = Filter f (FilterValue a) Gt -- | Greater-than or equal check. -- -- === Examples -- -- @ -- selectGreaterEqualAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectGreaterEqualAge = selectList [UserAge >=. 41 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f >=. a = Filter f (FilterValue a) Ge infix 4 <-., /<-. (<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v -- | Check if value is in given list. -- -- === Examples -- -- @ -- selectUsers :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectUsers = selectList [UserAge <-. [40, 41]] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -- -- -- @ -- selectSPJ :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSPJ = selectList [UserAge <-. [40]] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f <-. a = Filter f (FilterValues a) In -- | Check if value is not in given list. -- -- === Examples -- -- @ -- selectSimon :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSimon = selectList [UserAge /<-. [40]] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f /<-. a = Filter f (FilterValues a) NotIn infixl 3 ||. (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] -- | The OR of two lists of filters. For example: -- -- > selectList -- > ([ PersonAge >. 25 -- > , PersonAge <. 30 ] ||. -- > [ PersonIncome >. 15000 -- > , PersonIncome <. 25000 ]) -- > [] -- -- will filter records where a person's age is between 25 and 30 /or/ a -- person's income is between (15000 and 25000). -- -- If you are looking for an @(&&.)@ operator to do @(A AND B AND (C OR D))@ -- you can use the @(++)@ operator instead as there is no @(&&.)@. For -- example: -- -- > selectList -- > ([ PersonAge >. 25 -- > , PersonAge <. 30 ] ++ -- > ([PersonCategory ==. 1] ||. -- > [PersonCategory ==. 5])) -- > [] -- -- 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]] -- | Convert list of 'PersistValue's into textual representation of JSON -- object. This is a type-constrained synonym for 'toJsonText'. listToJSON :: [PersistValue] -> T.Text listToJSON = toJsonText -- | Convert map (list of tuples) into textual representation of JSON -- object. This is a type-constrained synonym for 'toJsonText'. mapToJSON :: [(T.Text, PersistValue)] -> T.Text mapToJSON = toJsonText -- | A more general way to convert instances of `ToJSON` type class to -- strict text '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 opts = foldr go (0, 0, []) opts where 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) persistent-2.14.6.0/Database/Persist/Types.hs0000644000000000000000000000526614476403105017142 0ustar0000000000000000-- | This module exports many types and functions for operating on -- @persistent@'s database representation. It's a bit of a kitchen sink. In the -- future, this module will be reorganized, and many of the dependent modules -- will be viewable on their own for easier documentation and organization. module Database.Persist.Types ( -- * Various Types of Names -- | There are so many kinds of names. @persistent@ defines newtype wrappers -- for 'Text' so you don't confuse what a name is and what it is -- supposed to be used for module Database.Persist.Names -- * Database Definitions -- ** Entity/Table Definitions -- | The 'EntityDef' type is used by @persistent@ to generate Haskell code, -- generate database migrations, and maintain metadata about entities. These -- are generated in the call to 'Database.Persist.TH.mkPersist'. , module Database.Persist.EntityDef -- ** Field definitions -- | The 'FieldDef' type is used to describe how a field should be -- represented at the Haskell and database layers. , module Database.Persist.FieldDef -- * Intermediate Values -- | The 'PersistValue' type is used as an intermediate layer between -- database and Haskell types. , module Database.Persist.PersistValue -- * Other Useful Stuff , Update (..) , BackendSpecificUpdate , SelectOpt (..) , Filter (..) , FilterValue (..) , BackendSpecificFilter , Key , Entity (..) , OverflowNatural(..) -- * The rest of the types , module Database.Persist.Types.Base ) where import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.EntityDef import Database.Persist.FieldDef import Database.Persist.Names import Database.Persist.PersistValue -- this module is a bit of a kitchen sink of types and concepts. the guts of -- persistent, just strewn across the table. in 2.13 let's get this cleaned up -- and a bit more tidy. import Database.Persist.Types.Base ( Attr , CascadeAction(..) , Checkmark(..) , CompositeDef(..) , EmbedEntityDef(..) , EmbedFieldDef(..) , ExtraLine , FieldAttr(..) , FieldCascade(..) , FieldDef(..) , FieldType(..) , ForeignDef(..) , ForeignFieldDef , IsNullable(..) , LiteralType(..) , PersistException(..) , PersistFilter(..) , PersistUpdate(..) , PersistValue(..) , ReferenceDef(..) , SqlType(..) , UniqueDef(..) , UpdateException(..) , WhyNullable(..) , fieldAttrsContainsNullable , keyAndEntityFields , noCascade , parseFieldAttrs ) persistent-2.14.6.0/Database/Persist/Names.hs0000644000000000000000000000431314476403105017071 0ustar0000000000000000{-# LANGUAGE DeriveLift #-} -- | This module contains types and functions for working with and -- disambiguating database and Haskell names. -- -- @since 2.13.0.0 module Database.Persist.Names where import Data.Text (Text) import Language.Haskell.TH.Syntax (Lift) -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` import Instances.TH.Lift () -- | Convenience operations for working with '-NameDB' types. -- -- @since 2.12.0.0 class DatabaseName a where escapeWith :: (Text -> str) -> (a -> str) -- | A 'FieldNameDB' represents the datastore-side name that @persistent@ -- will use for a field. -- -- @since 2.12.0.0 newtype FieldNameDB = FieldNameDB { unFieldNameDB :: Text } deriving (Show, Eq, Read, Ord, Lift) -- | @since 2.12.0.0 instance DatabaseName FieldNameDB where escapeWith f (FieldNameDB n) = f n -- | A 'FieldNameHS' represents the Haskell-side name that @persistent@ -- will use for a field. -- -- @since 2.12.0.0 newtype FieldNameHS = FieldNameHS { unFieldNameHS :: Text } deriving (Show, Eq, Read, Ord, Lift) -- | An 'EntityNameHS' represents the Haskell-side name that @persistent@ -- will use for an entity. -- -- @since 2.12.0.0 newtype EntityNameHS = EntityNameHS { unEntityNameHS :: Text } deriving (Show, Eq, Read, Ord, Lift) -- | An 'EntityNameDB' represents the datastore-side name that @persistent@ -- will use for an entity. -- -- @since 2.12.0.0 newtype EntityNameDB = EntityNameDB { unEntityNameDB :: Text } deriving (Show, Eq, Read, Ord, Lift) instance DatabaseName EntityNameDB where escapeWith f (EntityNameDB n) = f n -- | A 'ConstraintNameDB' represents the datastore-side name that @persistent@ -- will use for a constraint. -- -- @since 2.12.0.0 newtype ConstraintNameDB = ConstraintNameDB { unConstraintNameDB :: Text } deriving (Show, Eq, Read, Ord, Lift) -- | @since 2.12.0.0 instance DatabaseName ConstraintNameDB where escapeWith f (ConstraintNameDB n) = f n -- | An 'ConstraintNameHS' represents the Haskell-side name that @persistent@ -- will use for a constraint. -- -- @since 2.12.0.0 newtype ConstraintNameHS = ConstraintNameHS { unConstraintNameHS :: Text } deriving (Show, Eq, Read, Ord, Lift) persistent-2.14.6.0/Database/Persist/PersistValue.hs0000644000000000000000000002716214507117603020463 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} -- | This module contains an intermediate representation of values before the -- backends serialize them into explicit database types. -- -- @since 2.13.0.0 module Database.Persist.PersistValue ( PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific) , fromPersistValueText , LiteralType(..) ) where import Control.DeepSeq import qualified Data.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 Data.Time (Day, TimeOfDay, UTCTime) import Web.PathPieces (PathPiece(..)) import qualified Data.Aeson as A import qualified Data.ByteString as BS #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as AM #else import qualified Data.HashMap.Strict as AM #endif import Web.HttpApiData ( FromHttpApiData(..) , ToHttpApiData(..) , parseUrlPieceMaybe , readTextData ) -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistText Text | PersistByteString ByteString | PersistInt64 Int64 | PersistDouble Double | PersistRational Rational | PersistBool Bool | PersistDay Day | PersistTimeOfDay TimeOfDay | PersistUTCTime UTCTime | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)] | 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 deriving (Show, Read, Eq, Ord) -- | -- @since 2.14.4.0 instance NFData PersistValue where rnf val = case val of PersistText txt -> rnf txt PersistByteString bs -> rnf bs PersistInt64 i -> rnf i PersistDouble d -> rnf d PersistRational q -> rnf q PersistBool b -> rnf b PersistDay d -> rnf d PersistTimeOfDay t -> rnf t PersistUTCTime t -> rnf t PersistNull -> () PersistList vals -> rnf vals PersistMap vals -> rnf vals PersistObjectId bs -> rnf bs PersistArray vals -> rnf vals PersistLiteral_ ty bs -> ty `seq` rnf bs -- | A type that determines how a backend should handle the literal. -- -- @since 2.12.0.0 data LiteralType = 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 deriving (Show, Read, Eq, Ord) -- | This pattern synonym used to be a data constructor for the -- 'PersistValue' type. It was changed to be a pattern so that JSON-encoded -- database values could be parsed into their corresponding values. You -- should not use this, and instead prefer to pattern match on -- `PersistLiteral_` directly. -- -- If you use this, it will overlap a patern match on the 'PersistLiteral_, -- 'PersistLiteral', and 'PersistLiteralEscaped' patterns. If you need to -- disambiguate between these constructors, pattern match on -- 'PersistLiteral_' directly. -- -- @since 2.12.0.0 pattern PersistDbSpecific :: ByteString -> PersistValue pattern PersistDbSpecific bs <- PersistLiteral_ _ bs where PersistDbSpecific bs = PersistLiteral_ DbSpecific bs -- | This pattern synonym used to be a data constructor on 'PersistValue', -- but was changed into a catch-all pattern synonym to allow backwards -- compatiblity with database types. See the documentation on -- 'PersistDbSpecific' for more details. -- -- @since 2.12.0.0 pattern PersistLiteralEscaped :: ByteString -> PersistValue pattern PersistLiteralEscaped bs <- PersistLiteral_ _ bs where PersistLiteralEscaped bs = PersistLiteral_ Escaped bs -- | This pattern synonym used to be a data constructor on 'PersistValue', -- but was changed into a catch-all pattern synonym to allow backwards -- compatiblity with database types. See the documentation on -- 'PersistDbSpecific' for more details. -- -- @since 2.12.0.0 pattern PersistLiteral :: ByteString -> PersistValue pattern PersistLiteral bs <- PersistLiteral_ _ bs where PersistLiteral bs = PersistLiteral_ Unescaped bs {-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." #-} keyToText :: Key -> Text keyFromText :: Text -> Key #if MIN_VERSION_aeson(2,0,0) type Key = K.Key keyToText = K.toText keyFromText = K.fromText #else type Key = Text keyToText = id keyFromText = id #endif instance ToHttpApiData PersistValue where toUrlPiece val = case fromPersistValueText val of Left e -> error $ Text.unpack e Right y -> y instance FromHttpApiData PersistValue where parseUrlPiece input = PersistInt64 <$> parseUrlPiece input PersistList <$> readTextData input PersistText <$> return input where infixl 3 Left _ y = y x _ = x instance PathPiece PersistValue where toPathPiece = toUrlPiece fromPathPiece = parseUrlPieceMaybe fromPersistValueText :: PersistValue -> Either Text Text fromPersistValueText (PersistText s) = Right s fromPersistValueText (PersistByteString bs) = Right $ TE.decodeUtf8With lenientDecode bs fromPersistValueText (PersistInt64 i) = Right $ Text.pack $ show i fromPersistValueText (PersistDouble d) = Right $ Text.pack $ show d fromPersistValueText (PersistRational r) = Right $ Text.pack $ show r fromPersistValueText (PersistDay d) = Right $ Text.pack $ show d fromPersistValueText (PersistTimeOfDay d) = Right $ Text.pack $ show d fromPersistValueText (PersistUTCTime d) = Right $ Text.pack $ show d fromPersistValueText PersistNull = Left "Unexpected null" fromPersistValueText (PersistBool b) = Right $ Text.pack $ show b fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text" fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text" instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ Text.cons 's' t toJSON (PersistByteString b) = A.String $ Text.cons 'b' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistInt64 i) = A.Number $ fromIntegral i toJSON (PersistDouble d) = A.Number $ Data.Scientific.fromFloatDigits d toJSON (PersistRational r) = A.String $ Text.pack $ 'r' : show r toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ Text.pack $ 't' : show t toJSON (PersistUTCTime u) = A.String $ Text.pack $ 'u' : show u toJSON (PersistDay d) = A.String $ Text.pack $ 'd' : show d toJSON PersistNull = A.Null toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l toJSON (PersistMap m) = A.object $ map go m where go (k, v) = (keyFromText k, A.toJSON v) toJSON (PersistLiteral_ litTy b) = let encoded = TE.decodeUtf8 $ B64.encode b prefix = case litTy of DbSpecific -> 'p' Unescaped -> 'l' Escaped -> 'e' in A.String $ Text.cons prefix encoded toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a toJSON (PersistObjectId o) = A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) "" where (four, eight) = BS8.splitAt 4 o -- taken from crypto-api bs2i :: ByteString -> Integer bs2i bs = BS.foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs {-# INLINE bs2i #-} -- showHex of n padded with leading zeros if necessary to fill d digits -- taken from Data.BSON showHexLen :: (Show n, Integral n) => Int -> n -> ShowS showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n where sigDigits 0 = 1 sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1 instance A.FromJSON PersistValue where parseJSON (A.String t0) = case Text.uncons t0 of Nothing -> fail "Null string" Just ('p', t) -> either (\_ -> fail "Invalid base64") (return . PersistDbSpecific) $ B64.decode $ TE.encodeUtf8 t Just ('l', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteral) $ B64.decode $ TE.encodeUtf8 t Just ('e', t) -> either (\_ -> fail "Invalid base64") (return . PersistLiteralEscaped) $ B64.decode $ TE.encodeUtf8 t Just ('s', t) -> return $ PersistText t Just ('b', t) -> either (\_ -> fail "Invalid base64") (return . PersistByteString) $ B64.decode $ TE.encodeUtf8 t Just ('t', t) -> PersistTimeOfDay <$> readMay t Just ('u', t) -> PersistUTCTime <$> readMay t Just ('d', t) -> PersistDay <$> readMay t Just ('r', t) -> PersistRational <$> readMay t Just ('o', t) -> maybe (fail "Invalid base64") (return . PersistObjectId . i2bs (8 * 12) . fst) $ headMay $ readHex $ Text.unpack t Just (c, _) -> fail $ "Unknown prefix: " ++ [c] where headMay [] = Nothing headMay (x:_) = Just x readMay t = case reads $ Text.unpack t of (x, _):_ -> return x [] -> fail "Could not read" -- taken from crypto-api -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8). i2bs :: Int -> Integer -> ByteString i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8) {-# INLINE i2bs #-} parseJSON (A.Number n) = return $ if fromInteger (floor n) == n then PersistInt64 $ floor n else PersistDouble $ fromRational $ toRational n parseJSON (A.Bool b) = return $ PersistBool b parseJSON A.Null = return PersistNull parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a) parseJSON (A.Object o) = fmap PersistMap $ mapM go $ AM.toList o where go (k, v) = (,) (keyToText k) <$> A.parseJSON v persistent-2.14.6.0/Database/Persist/EntityDef.hs0000644000000000000000000001207614476403105017726 0ustar0000000000000000-- | An 'EntityDef' represents metadata about a type that @persistent@ uses to -- store the type in the database, as well as generate Haskell code from it. -- -- @since 2.13.0.0 module Database.Persist.EntityDef ( -- * The 'EntityDef' type EntityDef -- * Construction -- * Accessors , getEntityHaskellName , getEntityDBName , getEntityFields , getEntityFieldsDatabase , getEntityForeignDefs , getEntityUniques , getEntityUniquesNoPrimaryKey , getEntityId , getEntityIdField , getEntityKeyFields , getEntityComments , getEntityExtra , isEntitySum , entityPrimary , entitiesPrimary , keyAndEntityFields -- * Setters , setEntityId , setEntityIdDef , setEntityDBName , overEntityFields -- * Related Types , EntityIdDef(..) ) where import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Text (Text) import Database.Persist.EntityDef.Internal import Database.Persist.FieldDef import Database.Persist.Names import Database.Persist.Types.Base (ForeignDef, UniqueDef(..), entityKeyFields) -- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This does not include -- a @Primary@ key, if one is defined. A future version of @persistent@ will -- include a @Primary@ key among the 'Unique' constructors for the 'Entity'. -- -- @since 2.14.0.0 getEntityUniquesNoPrimaryKey :: EntityDef -> [UniqueDef] getEntityUniquesNoPrimaryKey ed = filter isNotPrimaryKey $ entityUniques ed where isNotPrimaryKey ud = let constraintName = unConstraintNameHS $ uniqueHaskell ud in constraintName /= unEntityNameHS (getEntityHaskellName ed) <> "PrimaryKey" -- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. As of version 2.14, -- this will also include the primary key on the entity, if one is defined. If -- you do not want the primary key, see 'getEntityUniquesNoPrimaryKey'. -- -- @since 2.13.0.0 getEntityUniques :: EntityDef -> [UniqueDef] getEntityUniques = entityUniques -- | Retrieve the Haskell name of the given entity. -- -- @since 2.13.0.0 getEntityHaskellName :: EntityDef -> EntityNameHS getEntityHaskellName = entityHaskell -- | Return the database name for the given entity. -- -- @since 2.13.0.0 getEntityDBName :: EntityDef -> EntityNameDB getEntityDBName = entityDB getEntityExtra :: EntityDef -> Map Text [[Text]] getEntityExtra = entityExtra -- | -- -- @since 2.13.0.0 setEntityDBName :: EntityNameDB -> EntityDef -> EntityDef setEntityDBName db ed = ed { entityDB = db } getEntityComments :: EntityDef -> Maybe Text getEntityComments = entityComments -- | -- -- @since 2.13.0.0 getEntityForeignDefs :: EntityDef -> [ForeignDef] getEntityForeignDefs = entityForeigns -- | Retrieve the list of 'FieldDef' that makes up the fields of the entity. -- -- This does not return the fields for an @Id@ column or an implicit @id@. It -- will return the key columns if you used the @Primary@ syntax for defining the -- primary key. -- -- This does not return fields that are marked 'SafeToRemove' or 'MigrationOnly' -- - so it only returns fields that are represented in the Haskell type. If you -- need those fields, use 'getEntityFieldsDatabase'. -- -- @since 2.13.0.0 getEntityFields :: EntityDef -> [FieldDef] getEntityFields = filter isHaskellField . entityFields -- | This returns all of the 'FieldDef' defined for the 'EntityDef', including -- those fields that are marked as 'MigrationOnly' (and therefore only present -- in the database) or 'SafeToRemove' (and a migration will drop the column if -- it exists in the database). -- -- For all the fields that are present on the Haskell-type, see -- 'getEntityFields'. -- -- @since 2.13.0.0 getEntityFieldsDatabase :: EntityDef -> [FieldDef] getEntityFieldsDatabase = entityFields -- | -- -- @since 2.13.0.0 isEntitySum :: EntityDef -> Bool isEntitySum = entitySum -- | -- -- @since 2.13.0.0 getEntityId :: EntityDef -> EntityIdDef getEntityId = entityId -- | -- -- @since 2.13.0.0 getEntityIdField :: EntityDef -> Maybe FieldDef getEntityIdField ed = case getEntityId ed of EntityIdField fd -> pure fd _ -> Nothing -- | Set an 'entityId' to be the given 'FieldDef'. -- -- @since 2.13.0.0 setEntityId :: FieldDef -> EntityDef -> EntityDef setEntityId fd = setEntityIdDef (EntityIdField fd) -- | -- -- @since 2.13.0.0 setEntityIdDef :: EntityIdDef -> EntityDef -> EntityDef setEntityIdDef i ed = ed { entityId = i } -- | -- -- @since 2.13.0.0 getEntityKeyFields :: EntityDef -> NonEmpty FieldDef getEntityKeyFields = entityKeyFields -- | TODO -- -- @since 2.13.0.0 setEntityFields :: [FieldDef] -> EntityDef -> EntityDef setEntityFields fd ed = ed { entityFields = fd } -- | Perform a mapping function over all of the entity fields, as determined by -- 'getEntityFieldsDatabase'. -- -- @since 2.13.0.0 overEntityFields :: ([FieldDef] -> [FieldDef]) -> EntityDef -> EntityDef overEntityFields f ed = setEntityFields (f (getEntityFieldsDatabase ed)) ed persistent-2.14.6.0/Database/Persist/EntityDef/Internal.hs0000644000000000000000000000104414476403105021473 0ustar0000000000000000-- | The 'EntityDef' type, fields, and constructor are exported from this -- module. Breaking changes to the 'EntityDef' type are not reflected in -- the major version of the API. Please import from -- "Database.Persist.EntityDef" instead. -- -- If you need this module, please file a GitHub issue why. -- -- @since 2.13.0.0 module Database.Persist.EntityDef.Internal ( EntityDef(..) , entityPrimary , entitiesPrimary , keyAndEntityFields , toEmbedEntityDef , EntityIdDef(..) ) where import Database.Persist.Types.Base persistent-2.14.6.0/Database/Persist/FieldDef.hs0000644000000000000000000000311714476403105017471 0ustar0000000000000000-- | -- -- @since 2.13.0.0 module Database.Persist.FieldDef ( -- * The 'FieldDef' type FieldDef -- ** Setters , setFieldAttrs , overFieldAttrs , addFieldAttr -- ** Helpers , isFieldNullable , isFieldMaybe , isFieldNotGenerated , isHaskellField -- * 'FieldCascade' , FieldCascade(..) , renderFieldCascade , renderCascadeAction , noCascade , CascadeAction(..) ) where import Database.Persist.FieldDef.Internal import Database.Persist.Types.Base ( FieldAttr(..) , FieldType(..) , IsNullable(..) , fieldAttrsContainsNullable , isHaskellField ) -- | Replace the 'FieldDef' 'FieldAttr' with the new list. -- -- @since 2.13.0.0 setFieldAttrs :: [FieldAttr] -> FieldDef -> FieldDef setFieldAttrs fas fd = fd { fieldAttrs = fas } -- | Modify the list of field attributes. -- -- @since 2.13.0.0 overFieldAttrs :: ([FieldAttr] -> [FieldAttr]) -> FieldDef -> FieldDef overFieldAttrs k fd = fd { fieldAttrs = k (fieldAttrs fd) } -- | Add an attribute to the list of field attributes. -- -- @since 2.13.0.0 addFieldAttr :: FieldAttr -> FieldDef -> FieldDef addFieldAttr fa = overFieldAttrs (fa :) -- | Check if the field definition is nullable -- -- @since 2.13.0.0 isFieldNullable :: FieldDef -> IsNullable isFieldNullable = fieldAttrsContainsNullable . fieldAttrs -- | Check if the field is `Maybe a` -- -- @since 2.13.0.0 isFieldMaybe :: FieldDef -> Bool isFieldMaybe field = case fieldType field of FTApp (FTTypeCon _ "Maybe") _ -> True _ -> False persistent-2.14.6.0/Database/Persist/FieldDef/Internal.hs0000644000000000000000000000047714476403105021253 0ustar0000000000000000-- | TODO: standard Internal moduel boilerplate -- -- @since 2.13.0.0 module Database.Persist.FieldDef.Internal ( FieldDef(..) , isFieldNotGenerated , FieldCascade(..) , renderFieldCascade , renderCascadeAction , noCascade , CascadeAction(..) ) where import Database.Persist.Types.Base persistent-2.14.6.0/Database/Persist/ImplicitIdDef.hs0000644000000000000000000000335314476403105020477 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- | This module contains types and functions for creating an 'ImplicitIdDef', -- which allows you to customize the implied ID column that @persistent@ -- generates. -- -- If this module doesn't suit your needs, you may want to import -- "Database.Persist.ImplicitIdDef.Internal" instead. If you do so, please file -- an issue on GitHub so we can support your needs. Breaking changes to that -- module will *not* be accompanied with a major version bump. -- -- @since 2.13.0.0 module Database.Persist.ImplicitIdDef ( -- * The Type ImplicitIdDef -- * Construction , mkImplicitIdDef -- * Autoincrementing Integer Key , autoIncrementingInteger -- * Getters -- * Setters , setImplicitIdDefMaxLen , unsafeClearDefaultImplicitId ) where import Language.Haskell.TH import Database.Persist.ImplicitIdDef.Internal import Database.Persist.Types.Base ( 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 -- default. -- -- @since 2.13.0.0 autoIncrementingInteger :: ImplicitIdDef autoIncrementingInteger = ImplicitIdDef { iidFieldType = \entName -> FTTypeCon Nothing $ unEntityNameHS entName `mappend` "Id" , iidFieldSqlType = SqlInt64 , iidType = \isMpsGeneric mpsBackendType -> ConT ''BackendKey `AppT` if isMpsGeneric then VarT (mkName "backend") else mpsBackendType , iidDefault = Nothing , iidMaxLen = Nothing } persistent-2.14.6.0/Database/Persist/ImplicitIdDef/Internal.hs0000644000000000000000000001713714476403105022260 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeInType #-} -- | WARNING: This is an @Internal@ module. As such, breaking changes to the API -- of this module will not have a corresponding major version bump. -- -- Please depend on "Database.Persist.ImplicitIdDef" instead. If you can't use -- that module, please file an issue on GitHub with your desired use case. -- -- @since 2.13.0.0 module Database.Persist.ImplicitIdDef.Internal where import Data.Proxy import Data.Text (Text) import qualified Data.Text as Text 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 import Database.Persist.Sql.Class import Database.Persist.Types -- | A specification for how the implied ID columns are created. -- -- By default, @persistent@ will give each table a default column named @id@ -- (customizable by 'PersistSettings'), and the column type will be whatever -- you'd expect from @'BackendKey' yourBackendType@. For The 'SqlBackend' type, -- this is an auto incrementing integer primary key. -- -- You might want to give a different example. A common use case in postgresql -- is to use the UUID type, and automatically generate them using a SQL -- function. -- -- Previously, you'd need to add a custom @Id@ annotation for each model. -- -- > User -- > Id UUID default="uuid_generate_v1mc()" -- > name Text -- > -- > Dog -- > Id UUID default="uuid_generate_v1mc()" -- > name Text -- > user UserId -- -- Now, you can simply create an 'ImplicitIdDef' that corresponds to this -- declaration. -- -- @ -- newtype UUID = UUID 'ByteString' -- -- instance 'PersistField' UUID where -- 'toPersistValue' (UUID bs) = -- 'PersistLiteral_' 'Escaped' bs -- 'fromPersistValue' pv = -- case pv of -- PersistLiteral_ Escaped bs -> -- Right (UUID bs) -- _ -> -- Left "nope" -- -- instance 'PersistFieldSql' UUID where -- 'sqlType' _ = 'SqlOther' "UUID" -- @ -- -- With this instance at the ready, we can now create our implicit definition: -- -- @ -- uuidDef :: ImplicitIdDef -- uuidDef = mkImplicitIdDef \@UUID "uuid_generate_v1mc()" -- @ -- -- And we can use 'setImplicitIdDef' to use this with the 'MkPersistSettings' -- for our block. -- -- @ -- mkPersist (setImplicitIdDef uuidDef sqlSettings) [persistLowerCase| ... |] -- @ -- -- TODO: either explain interaction with mkMigrate or fix it. see issue #1249 -- for more details. -- -- @since 2.13.0.0 data ImplicitIdDef = ImplicitIdDef { iidFieldType :: EntityNameHS -> FieldType -- ^ The field type. Accepts the 'EntityNameHS' if you want to refer to it. -- By default, @Id@ is appended to the end of the Haskell name. -- -- @since 2.13.0.0 , iidFieldSqlType :: SqlType -- ^ The 'SqlType' for the default column. By default, this is 'SqlInt64' to -- correspond with an autoincrementing integer primary key. -- -- @since 2.13.0.0 , iidType :: Bool -> Type -> Type -- ^ The Bool argument is whether or not the 'MkPersistBackend' type has the -- 'mpsGeneric' field set. -- -- The 'Type' is the 'mpsBackend' value. -- -- The default uses @'BackendKey' 'SqlBackend'@ (or a generic equivalent). -- -- @since 2.13.0.0 , iidDefault :: Maybe Text -- ^ The default expression for the field. Note that setting this to -- 'Nothing' is unsafe. see -- https://github.com/yesodweb/persistent/issues/1247 for more information. -- -- With some cases - like the Postgresql @SERIAL@ type - this is safe, since -- there's an implied default. -- -- @since 2.13.0.0 , iidMaxLen :: Maybe Integer -- ^ Specify the maximum length for a key column. This is necessary for -- @VARCHAR@ columns, like @UUID@ in MySQL. MySQL will throw a runtime error -- if a text or binary column is used in an index without a length -- specification. -- -- @since 2.13.0.0 } -- | Create an 'ImplicitIdDef' based on the 'Typeable' and 'PersistFieldSql' -- constraints in scope. -- -- This function uses the @TypeApplications@ syntax. Let's look at an example -- that works with Postgres UUIDs. -- -- > newtype UUID = UUID Text -- > deriving newtype PersistField -- > -- > instance PersistFieldSql UUID where -- > sqlType _ = SqlOther "UUID" -- > -- > idDef :: ImplicitIdDef -- > idDef = mkImplicitIdDefTypeable @UUID "uuid_generate_v1mc()" -- -- This 'ImplicitIdDef' will generate default UUID columns, and the database -- will call the @uuid_generate_v1mc()@ function to generate the value for new -- rows being inserted. -- -- If the type @t@ is 'Text' or 'String' then a @max_len@ attribute of 200 is -- set. To customize this, use 'setImplicitIdDefMaxLen'. -- -- @since 2.13.0.0 mkImplicitIdDef :: forall t. (Typeable t, PersistFieldSql t) => Text -- ^ The default expression to use for columns. Should be valid SQL in the -- language you're using. -> ImplicitIdDef mkImplicitIdDef def = ImplicitIdDef { iidFieldType = \_ -> fieldTypeFromTypeable @t , iidFieldSqlType = sqlType (Proxy @t) , iidType = \_ _ -> liftType @t , iidDefault = Just def , iidMaxLen = -- this follows a special casing behavior that @persistent@ has done -- for a while now. this keeps folks code from breaking and probably -- is mostly what people want. asum [ 200 <$ eqT @t @Text , 200 <$ eqT @t @String ] } -- | Set the maximum length of the implied ID column. This is required for -- any type where the associated 'SqlType' is a @TEXT@ or @VARCHAR@ sort of -- thing. -- -- @since 2.13.0.0 setImplicitIdDefMaxLen :: Integer -> ImplicitIdDef -> ImplicitIdDef setImplicitIdDefMaxLen i iid = iid { iidMaxLen = Just i } -- | This function converts a 'Typeable' type into a @persistent@ -- representation of the type of a field - 'FieldTyp'. -- -- @since 2.13.0.0 fieldTypeFromTypeable :: forall t. (PersistField t, Typeable t) => FieldType fieldTypeFromTypeable = go (typeRep @t) where go :: forall k (a :: k). TypeRep a -> FieldType go tr = case tr of Con tyCon -> FTTypeCon Nothing $ Text.pack $ tyConName tyCon App trA trB -> FTApp (go trA) (go trB) Fun _ _ -> error "No functions in field defs." -- | Remove the default attribute of the 'ImplicitIdDef' column. This will -- require you to provide an ID for the model with every insert, using -- 'insertKey' instead of 'insert', unless the type has some means of getting -- around that in the migrations. -- -- As an example, the Postgresql @SERIAL@ type expands to an autoincrementing -- integer. Postgres will implicitly create the relevant series and set the -- default to be @NEXTVAL('series_name')@. A default is therefore unnecessary to -- use for this type. -- -- However, for a @UUID@, postgres *does not* have an implicit default. You must -- either specify a default UUID generation function, or insert them yourself -- (again, using 'insertKey'). -- -- This function will be deprecated in the future when omiting the default -- implicit ID column is more fully supported. -- -- @since 2.13.0.0 unsafeClearDefaultImplicitId :: ImplicitIdDef -> ImplicitIdDef unsafeClearDefaultImplicitId iid = iid { iidDefault = Nothing } persistent-2.14.6.0/Database/Persist/TH.hs0000644000000000000000000035354214507124116016351 0ustar0000000000000000{-# 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 Data.List (foldl') 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 and -- 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)] (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 = 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 <- typeErrorMultipleCtx 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 = 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 _) = 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] (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 = foldl AppT (ConT cla) tys mkEqualP :: Type -> Type -> Pred mkEqualP tleft tright = foldl AppT EqualityT [tleft, tright] notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness isStrict :: Bang isStrict = Bang NoSourceUnpackedness SourceStrict instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing -- | Check that all of Persistent's required extensions are enabled, or else fail compilation -- -- This function should be called before any code that depends on one of the required extensions being enabled. requirePersistentExtensions :: Q () requirePersistentExtensions = requireExtensions requiredExtensions where requiredExtensions = fmap pure [ DerivingStrategies , GeneralizedNewtypeDeriving , StandaloneDeriving , UndecidableInstances , MultiParamTypeClasses ] mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do let entityHaskellName = getEntityHaskellName $ unboundEntityDef ed allFields = getUnboundFieldDefs ed mkEntityFieldConstr fieldHaskellName = conE $ filterConName' mps entityHaskellName fieldHaskellName :: Q Exp regularFields <- forM (toList allFields) $ \fieldDef -> do let fieldHaskellName = unboundFieldNameHS fieldDef let fieldNameT :: Q Type fieldNameT = litT $ strTyLit $ T.unpack $ lowerFirstIfId $ unFieldNameHS fieldHaskellName lowerFirstIfId "Id" = "id" lowerFirstIfId xs = xs fieldTypeT | fieldHaskellName == FieldNameHS "Id" = conT ''Key `appT` recordNameT | otherwise = pure $ maybeIdType mps entityMap fieldDef Nothing Nothing entityFieldConstr = mkEntityFieldConstr fieldHaskellName mkInstance fieldNameT fieldTypeT entityFieldConstr mkey <- do let fieldHaskellName = FieldNameHS "Id" entityFieldConstr = mkEntityFieldConstr fieldHaskellName fieldTypeT = conT ''Key `appT` recordNameT mkInstance [t|"id"|] fieldTypeT entityFieldConstr pure (mkey <> join regularFields) where nameG = mkEntityDefGenericName ed recordNameT | mpsGeneric mps = conT nameG `appT` varT backendName | otherwise = entityDefConT ed mkInstance fieldNameT fieldTypeT entityFieldConstr = [d| instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where symbolToField = $(entityFieldConstr) |] -- | Pass in a list of lists of extensions, where any of the given -- extensions will satisfy it. For example, you might need either GADTs or -- ExistentialQuantification, so you'd write: -- -- > requireExtensions [[GADTs, ExistentialQuantification]] -- -- But if you need TypeFamilies and MultiParamTypeClasses, then you'd -- write: -- -- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] requireExtensions :: [[Extension]] -> Q () requireExtensions requiredExtensions = do -- isExtEnabled breaks the persistent-template benchmark with the following error: -- Template Haskell error: Can't do `isExtEnabled' in the IO monad -- You can workaround this by replacing isExtEnabled with (pure . const True) unenabledExtensions <- filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions case mapMaybe listToMaybe unenabledExtensions of [] -> pure () [extension] -> fail $ mconcat [ "Generating Persistent entities now requires the " , show extension , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n" , extensionToPragma extension ] extensions -> fail $ mconcat [ "Generating Persistent entities now requires the following language extensions:\n\n" , List.intercalate "\n" (fmap show extensions) , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" , List.intercalate "\n" (fmap extensionToPragma extensions) ] where extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" -- | creates a TH Name for use in the ToJSON instance fieldToJSONValName :: UnboundFieldDef -> Q Name fieldToJSONValName = newName . T.unpack . unFieldNameHSForJSON . unboundFieldNameHS -- | This special-cases "type_" and strips out its underscore. When -- used for JSON serialization and deserialization, it works around -- unFieldNameHSForJSON :: FieldNameHS -> Text unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS where fixTypeUnderscore = \case "type" -> "type_" name -> name entityDefConK :: UnboundEntityDef -> Kind entityDefConK = conK . mkEntityDefName entityDefConT :: UnboundEntityDef -> Q Type entityDefConT = pure . entityDefConK entityDefConE :: UnboundEntityDef -> Exp entityDefConE = ConE . mkEntityDefName -- | creates a TH Name for an entity's field, based on the entity -- name and the field name, so for example: -- -- Customer -- name Text -- -- This would generate `customerName` as a TH Name fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name fieldNameToRecordName mps entDef fieldName = mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName where mUnderscore | mpsGenerateLenses mps = Just "_" | otherwise = Nothing -- | as above, only takes a `FieldDef` fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (unboundFieldNameHS fieldDef) -- | creates a TH Name for a lens on an entity's field, based on the entity -- name and the field name, so as above but for the Lens -- -- Customer -- name Text -- -- Generates a lens `customerName` when `mpsGenerateLenses` is true -- while `fieldNameToRecordName` generates a prefixed function -- `_customerName` mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name mkEntityLensName mps entDef fieldDef = mkRecordName mps Nothing (entityHaskell (unboundEntityDef entDef)) (unboundFieldNameHS fieldDef) mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name mkRecordName mps prefix entNameHS fieldNameHS = mkName $ T.unpack . avoidKeyword $ fromMaybe "" prefix <> lowerFirst recName where recName :: Text recName | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) | otherwise = fieldNameText entityNameText :: Text entityNameText = unEntityNameHS entNameHS fieldNameText :: Text fieldNameText = unFieldNameHS fieldNameHS avoidKeyword :: Text -> Text avoidKeyword name = if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name haskellKeywords :: Set.Set Text haskellKeywords = Set.fromList ["case","class","data","default","deriving","do","else" ,"if","import","in","infix","infixl","infixr","instance","let","module" ,"newtype","of","then","type","where","_" ,"foreign" ] -- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name] mkEntityDefDeriveNames mps entDef = let entityInstances = mkName . T.unpack <$> entityDerives (unboundEntityDef entDef) additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps in entityInstances <> additionalInstances -- | Make a TH Name for the EntityDef's Haskell type mkEntityNameHSName :: EntityNameHS -> Name mkEntityNameHSName = mkName . T.unpack . unEntityNameHS -- | As above only taking an `EntityDef` mkEntityDefName :: UnboundEntityDef -> Name mkEntityDefName = mkEntityNameHSName . entityHaskell . unboundEntityDef -- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric mkEntityDefGenericName :: UnboundEntityDef -> Name mkEntityDefGenericName = mkEntityNameHSGenericName . entityHaskell . unboundEntityDef mkEntityNameHSGenericName :: EntityNameHS -> Name mkEntityNameHSGenericName name = mkName $ T.unpack (unEntityNameHS name <> "Generic") -- needs: -- -- * entityHaskell -- * field on EntityDef -- * fieldHaskell -- * field on FieldDef -- sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name sumConstrName mps entDef unboundFieldDef = mkName $ T.unpack name where name | mpsPrefixFields mps = modifiedName ++ "Sum" | otherwise = fieldName ++ "Sum" fieldNameHS = unboundFieldNameHS unboundFieldDef modifiedName = mpsConstraintLabelModifier mps entityName fieldName entityName = unEntityNameHS $ getUnboundEntityNameHS entDef fieldName = upperFirst $ unFieldNameHS fieldNameHS -- | Turn a ConstraintName into a TH Name mkConstraintName :: ConstraintNameHS -> Name mkConstraintName (ConstraintNameHS name) = mkName (T.unpack name) keyIdName :: UnboundEntityDef -> Name keyIdName = mkName . T.unpack . keyIdText keyIdText :: UnboundEntityDef -> Text keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id" unKeyName :: UnboundEntityDef -> Name unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef unKeyExp :: UnboundEntityDef -> Exp unKeyExp ent = fieldSel (keyConName ent) (unKeyName ent) backendT :: Type backendT = VarT backendName backendName :: Name backendName = mkName "backend" -- needs: -- -- * keyText -- * entityNameHaskell -- * fields -- * fieldHaskell -- -- keyConName :: EntityNameHS -> [FieldHaskell] -> Name keyConName :: UnboundEntityDef -> Name keyConName entDef = keyConName' (getUnboundEntityNameHS entDef) (unboundFieldNameHS <$> unboundEntityFields (entDef)) keyConName' :: EntityNameHS -> [FieldNameHS] -> Name keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName where resolveConflict kn = if conflict then kn `mappend` "'" else kn conflict = any (== FieldNameHS "key") entFields -- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp keyConExp :: UnboundEntityDef -> Exp keyConExp ed = ConE $ keyConName ed keyText :: UnboundEntityDef -> Text keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key" keyText' :: EntityNameHS -> Text keyText' entName = unEntityNameHS entName ++ "Key" keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name keyFieldName mps entDef fieldDef | pkNewtype mps entDef = unKeyName entDef | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` fieldName where fieldName = modifyFieldName (unFieldNameHS fieldDef) modifyFieldName = if mpsCamelCaseCompositeKeySelector mps then upperFirst else id filterConName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name filterConName mps (unboundEntityDef -> entity) field = filterConName' mps (entityHaskell entity) (unboundFieldNameHS field) filterConName' :: MkPersistSettings -> EntityNameHS -> FieldNameHS -> Name filterConName' mps entity field = mkName $ T.unpack name where name | field == FieldNameHS "Id" = entityName ++ fieldName | mpsPrefixFields mps = modifiedName | otherwise = fieldName modifiedName = mpsConstraintLabelModifier mps entityName fieldName entityName = unEntityNameHS entity fieldName = upperFirst $ unFieldNameHS field {-| Splice in a list of all 'EntityDef' in scope. This is useful when running 'mkPersist' to ensure that all entity definitions are available for setting foreign keys, and for performing migrations with all entities available. 'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. For example, @ share [ mkPersistWith sqlSettings $(discoverEntities) ] [persistLowerCase| ... |] @ Likewise, to run migrations with all entity instances in scope, you'd write: @ migrateAll = migrateModels $(discoverEntities) @ Note that there is some odd behavior with Template Haskell and splicing groups. If you call 'discoverEntities' in the same module that defines 'PersistEntity' instances, you need to ensure they are in different top-level binding groups. You can write @$(pure [])@ at the top level to do this. @ -- Foo and Bar both export an instance of PersistEntity import Foo import Bar -- Since Foo and Bar are both imported, discoverEntities can find them here. mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| User name Text age Int |] -- onlyFooBar is defined in the same 'top level group' as the above generated -- instance for User, so it isn't present in this list. onlyFooBar :: [EntityDef] onlyFooBar = $(discoverEntities) -- We can manually create a new binding group with this, which splices an -- empty list of declarations in. $(pure []) -- fooBarUser is able to see the 'User' instance. fooBarUser :: [EntityDef] fooBarUser = $(discoverEntities) @ @since 2.13.0.0 -} discoverEntities :: Q Exp discoverEntities = do instances <- reifyInstances ''PersistEntity [VarT (mkName "a")] let types = mapMaybe getDecType instances getDecType dec = case dec of InstanceD _moverlap [] typ _decs -> stripPersistEntity typ _ -> Nothing stripPersistEntity typ = case typ of AppT (ConT tyName) t | tyName == ''PersistEntity -> Just t _ -> Nothing fmap ListE $ forM types $ \typ -> do [e| entityDef (Proxy :: Proxy $(pure typ)) |] setNull :: NonEmpty UnboundFieldDef -> Bool setNull (fd :| fds) = let nullSetting = isNull fd isNull = (NotNullable /=) . isUnboundFieldNullable in if all ((nullSetting ==) . isNull) fds then nullSetting else error $ "foreign key columns must all be nullable or non-nullable" ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd:fds)) persistent-2.14.6.0/Database/Persist/Quasi.hs0000644000000000000000000010272414507117603017115 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-| This module defines the Persistent entity syntax used in the quasiquoter to generate persistent entities. The basic structure of the syntax looks like this: > TableName > fieldName FieldType > otherField String > nullableField Int Maybe You start an entity definition with the table name, in this case, @TableName@. It's followed by a list of fields on the entity, which have the basic form @fieldName FieldType@. You can indicate that a field is nullable with 'Maybe' at the end of the type. @persistent@ automatically generates an ID column for you, if you don't specify one, so the above table definition corresponds to the following SQL: > CREATE TABLE table_name ( > id SERIAL PRIMARY KEY, > field_name field_type NOT NULL, > other_field varchar NOT NULL, > nullable_field int NULL > ); Note that the exact SQL that is generated can be customized using the 'PersistSettings' that are passed to the 'parse' function. It generates a Haskell datatype with the following form: @ data TableName = TableName { tableNameFieldName :: FieldType , tableNameOtherField :: String , tableNameNullableField :: Maybe Int } @ As with the SQL generated, the specifics of this are customizable. See the "Database.Persist.TH" module for details. = Deriving You can add a deriving clause to a table, and the generated Haskell type will have a deriving clause with that. Unlike normal Haskell syntax, you don't need parentheses or commas to separate the classes, and you can even have multiple deriving clauses. > User > name String > age Int > deriving Eq Show > deriving Ord = Unique Keys You can define a uniqueness key on a table with the following format: > User > name String > age Int > > UniqueUserName name This will put a unique index on the @user@ table and the @name@ field. = Setting defaults You can use a @default=${sql expression}@ clause to set a default for a field. The thing following the @=@ is interpreted as SQL that will be put directly into the table definition. @ User name Text admin Bool default=false @ This creates a SQL definition like this: > CREATE TABLE user ( > id SERIAL PRIMARY KEY, > name VARCHAR NOT NULL, > admin BOOL DEFAULT=false > ); A restriction here is that you still need to provide a value when performing an @insert@, because the generated Haskell type has the form: @ data User = User { userName :: Text , userAdmin :: Bool } @ You can work around this by using a 'Maybe Bool' and supplying 'Nothing' by default. __Note__: Persistent determines whether or not to migrate a column's default value by comparing the exact string found in your @models@ file with the one returned by the database. If a database canonicalizes the SQL @FALSE@ from your @models@ file to @false@ in the database, Persistent will think the default value needs to be migrated and . To workaround this, find the exact SQL your DBMS uses for the default value. For example, using postgres: @ psql database_name # Open postgres \\d+ table_name -- describe the table schema @ @ ... created | timestamp without time zone | not null default now() @ Then use the listed default value SQL inside your @models@ file. = Custom ID column If you don't want to use the default ID column type of 'Int64', you can set a custom type with an @Id@ field. This @User@ has a @Text@ ID. > User > Id Text > name Text > age Int If you do this, it's a good idea to set a default for the ID. Otherwise, you will need to use 'insertKey' instead of 'insert' when performing inserts. @ 'insertKey' (UserKey "Hello world!") (User "Bob" 32) @ If you attempt to do @'insert' (User "Bob" 32)@, then you will receive a runtime error because the SQL database doesn't know how to make an ID for you anymore. So instead just use a default expression, like this: @ User Id Text default=generate_user_id() name Text age Int @ = Custom Primary Keys Sometimes you don't want to have an ID column, and you want a different sort of primary key. This is a table that stores unique email addresses, and the email is the primary key. We store the first and second part (eg @first\@second@) separately. @ Email firstPart Text secondPart Text Primary firstPart secondPart @ This creates a table with the following form: @ CREATE TABLE email ( first_part varchar, second_part varchar, PRIMARY KEY (first_part, second_part) @ Since the primary key for this table is part of the record, it's called a "natural key" in the SQL lingo. As a key with multiple fields, it is also a "composite key." You can specify a @Primary@ key with a single field, too. = Overriding SQL You can use a @sql=custom@ annotation to provide some customization on the entity and field. For example, you might prefer to name a table differently than what @persistent@ will do by default. You may also prefer to name a field differently. @ User sql=big_user_table fullName String sql=name age Int @ This will alter the generated SQL to be: @ CREATE 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"]] @ == @MigrationOnly@ Introduced with @persistent-template@ 1.2.0. The purpose of this attribute is to mark a field which will be entirely ignored by the normal processing, but retained in the database definition for purposes of migration. This means, in SQL, a column will not be flagged for removal by the migration scripts, even though it is not used in your code. This is useful for phasing out usage of a column before entirely removing it, or having columns which are needed by other tools but not by Persistent. @ Person name Text age Int unusedField ByteString Maybe MigrationOnly @ Note that you almost certainly want to either mark the field as @Maybe@ or provide a default value, otherwise insertions will fail. == @SafeToRemove@ This is intended to be used as part of a deprecation of a field, after @MigrationOnly@ has been used usually. This works somewhat as a superset of the functionality of @MigrationOnly@. In addition, the field will be removed from the database if it is present. Note that this is a destructive change which you are marking as safe. == Constraints Migration will remove any manual constraints from your tables. Exception: constraints whose names begin with the string @__manual_@ (which starts with two underscores) will be preserved. = Foreign Keys If you define an entity and want to refer to it in another table, you can use the entity's Id type in a column directly. @ Person name Text Dog name Text owner PersonId @ This automatically creates a foreign key reference from @Dog@ to @Person@. The foreign key constraint means that, if you have a @PersonId@ on the @Dog@, the database guarantees that the corresponding @Person@ exists in the database. If you try to delete a @Person@ out of the database that has a @Dog@, you'll receive an exception that a foreign key violation has occurred. == @constraint=@ You can use the @constraint=@ attribute to override the constraint name used in migrations. This is useful particularly when the automatically generated constraint names exceed database limits (e.g. MySQL does not allow constraint names longer than 64 characters). @ VeryLongTableName name Text AnotherVeryLongTableName veryLongTableNameId VeryLongTableNameId constraint=short_foreign_key @ == OnUpdate and OnDelete These options affects how a referring record behaves when the target record is changed. There are several options: * 'Restrict' - This is the default. It prevents the action from occurring. * 'Cascade' - this copies the change to the child record. If a parent record is deleted, then the child record will be deleted too. * 'SetNull' - If the parent record is modified, then this sets the reference to @NULL@. This only works on @Maybe@ foreign keys. * 'SetDefault' - This will set the column's value to the @default@ for the column, if specified. To specify the behavior for a reference, write @OnUpdate@ or @OnDelete@ followed by the action. @ Record -- If the referred Foo is deleted or updated, then this record will -- also be deleted or updated. fooId FooId OnDeleteCascade OnUpdateCascade -- If the referred Bar is deleted, then we'll set the reference to -- 'Nothing'. If the referred Bar is updated, then we'll cascade the -- update. barId BarId Maybe OnDeleteSetNull OnUpdateCascade -- If the referred Baz is deleted, then we set to the default ID. bazId BazId OnDeleteSetDefault default=1 @ Let's demonstrate this with a shopping cart example. @ User name Text Cart user UserId Maybe CartItem cartId CartId itemId ItemId Item name Text price Int @ Let's consider how we want to handle deletions and updates. If a @User@ is deleted or update, then we want to cascade the action to the associated @Cart@. @ Cart user UserId Maybe OnDeleteCascade OnUpdateCascade @ If an @Item@ is deleted, then we want to set the @CartItem@ to refer to a special "deleted item" in the database. If a @Cart@ is deleted, though, then we just want to delete the @CartItem@. @ CartItem cartId CartId OnDeleteCascade itemId ItemId OnDeleteSetDefault default=1 @ == @Foreign@ keyword The above example is a "simple" foreign key. It refers directly to the Id column, and it only works with a non-composite primary key. We can define more complicated foreign keys using the @Foreign@ keyword. A pseudo formal syntax for @Foreign@ is: @ Foreign $(TargetEntity) [$(cascade-actions)] $(constraint-name) $(columns) [ $(references) ] columns := column0 [column1 column2 .. columnX] references := References $(target-columns) target-columns := target-column0 [target-column1 target-columns2 .. target-columnX] @ Columns are the columns as defined on this entity. @target-columns@ are the columns as defined on the target entity. Let's look at some examples. === Composite Primary Key References The most common use for this is to refer to a composite primary key. Since composite primary keys take up more than one column, we can't refer to them with a single @persistent@ column. @ Email firstPart Text secondPart Text Primary firstPart secondPart User name Text emailFirstPart Text emailSecondPart Text Foreign Email fk_user_email emailFirstPart emailSecondPart @ If you omit the @References@ keyword, then it assumes that the foreign key reference is for the target table's primary key. If we wanted to be fully redundant, we could specify the @References@ keyword. @ Foreign Email fk_user_email emailFirstPart emailSecondPart References firstPart secondPart @ We can specify delete/cascade behavior directly after the target table. @ Foreign Email OnDeleteCascade OnUpdateCascade fk_user_email emailFirstPart emailSecondPart @ Now, if the email is deleted or updated, the user will be deleted or updated to match. === Non-Primary Key References SQL database backends allow you to create a foreign key to any column(s) with a Unique constraint. Persistent does not check this, because you might be defining your uniqueness constraints outside of Persistent. To do this, we must use the @References@ keyword. @ User name Text email Text UniqueEmail email Notification content Text sentTo Text Foreign User fk_noti_user sentTo References email @ If the target uniqueness constraint has multiple columns, then you must specify them independently. @ User name Text emailFirst Text emailSecond Text UniqueEmail emailFirst emailSecond Notification content Text sentToFirst Text sentToSecond Text Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst emailSecond @ = Documentation Comments The quasiquoter supports ordinary comments with @--@ and @#@. Since @persistent-2.10.5.1@, it also supports documentation comments. The grammar for documentation comments is similar to Haskell's Haddock syntax, with a few restrictions: 1. Only the @-- | @ form is allowed. 2. You must put a space before and after the @|@ pipe character. 3. The comment must be indented at the same level as the entity or field it documents. An example of the field documentation is: @ -- | I am a doc comment for a User. Users are important -- | to the application, and should be treasured. User -- | Users have names. Call them by names. name String -- | A user can be old, or young, and we care about -- | this for some reason. age Int @ The documentation is present on the @entityComments@ field on the @EntityDef@ for the entity: @ >>> let userDefinition = entityDef (Proxy :: Proxy User) >>> entityComments userDefinition "I am a doc comment for a User. Users are important\nto the application, and should be treasured.\n" @ Likewise, the field documentation is present in the @fieldComments@ field on the @FieldDef@ present in the @EntityDef@: @ >>> let userFields = entityFields userDefinition >>> let comments = map fieldComments userFields >>> mapM_ putStrLn comments "Users have names. Call them by names." "A user can be old, or young, and we care about\nthis for some reason." @ Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False). @persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. = Sum types == Field level You'll frequently want to store an enum of values in your database. For example, you might describe a @Person@'s employment status as being @Employed@, @Unemployed@, or @Retired@. In Haskell this is represented with a sum type, and Persistent provides a Template Haskell function to marshall these values to and from the database: @ -- @Employment.hs {-# LANGUAGE TemplateHaskell #-} module Employment where import Database.Persist.TH import Prelude data Employment = Employed | Unemployed | Retired deriving (Show, Read, Eq) derivePersistField "Employment" @ @derivePersistField@ stores sum type values as strins in the database. While not as efficient as using integers, this approach simplifies adding and removing values from your enumeration. Due to the GHC Stage Restriction, the call to the Template Haskell function @derivePersistField@ must be in a separate module than where the generated code is used. Note: If you created a new module, make sure add it to the @exposed-modules@ section of your Cabal file. Use the module by importing it into your @Model.hs@ file: @ -- @Model.hs import Employment @ and use it in the @models@ DSL: @ Person employment Employment @ You can export the Employment module from Import to use it across your app: @ -- @Import.hs import Employment as Import @ === Entity-level NOTE: This feature is deprecated as of version 2.14 and will be removed in 2.15 (unless there are many complaints). The demonstrate their usage. Note the use of the sign @+@ in front of the entity name. The schema in the test is reproduced here: @ share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase| Bicycle brand T.Text Car make T.Text model T.Text +Vehicle bicycle BicycleId car CarId |] @ Let's check out the definition of the Haskell type @Vehicle@. Using @ghci@, we can query for @:info Vehicle@: >>> :i Vehicle type Vehicle = VehicleGeneric SqlBackend -- Defined at .../Projects/persistent/persistent-test/src/SumTypeTest.hs:26:1 >>> :i VehicleGeneric type role VehicleGeneric nominal data VehicleGeneric backend = VehicleBicycleSum (Key (BicycleGeneric backend)) | VehicleCarSum (Key (CarGeneric backend)) -- Defined at .../persistent/persistent-test/src/SumTypeTest.hs:26:1 -- lots of instances follow... A @VehicleGeneric@ has two constructors: - @VehicleBicycleSum@ with a @Key (BicycleGeneric backend)@ field - @VehicleCarSum@ with a @Key (CarGeneric backend)@ field The @Bicycle@ and @Car@ are typical @persistent@ entities. This generates the following SQL migrations (formatted for readability): @ CREATE TABLE "bicycle" ( "id" INTEGER PRIMARY KEY, "brand" VARCHAR NOT NULL ); CREATE TABLE "car"( "id" INTEGER PRIMARY KEY, "make" VARCHAR NOT NULL, "model" VARCHAR NOT NULL ); CREATE TABLE "vehicle"( "id" INTEGER PRIMARY KEY, "bicycle" INTEGER NULL REFERENCES "bicycle", "car" INTEGER NULL REFERENCES "car" ); @ The @vehicle@ table contains a nullable foreign key reference to both the bicycle and the car tables. A SQL query that grabs all the vehicles from the database looks like this (note the @??@ is for the @persistent@ raw SQL query functions): @ SELECT ??, ??, ?? FROM vehicle LEFT JOIN car ON vehicle.car = car.id LEFT JOIN bicycle ON vehicle.bicycle = bicycle.id @ If we use the above query with @rawSql@, we'd get the following result: @ getVehicles :: SqlPersistM [ ( Entity Vehicle , Maybe (Entity Bicycle) , Maybe (Entity Car) ) ] @ This result has some post-conditions that are not guaranteed by the types *or* the schema. The constructor for @Entity Vehicle@ is going to determine which of the other members of the tuple is @Nothing@. We can convert this to a friendlier domain model like this: @ data Vehicle' = Car' Text Text | Bike Text check = do result <- getVehicles pure (map convert result) convert :: (Entity Vehicle, Maybe (Entity Bicycle), Maybe (Entity Car)) -> Vehicle' convert (Entity _ (VehicycleBicycleSum _), Just (Entity _ (Bicycle brand)), _) = Bike brand convert (Entity _ (VehicycleCarSum _), _, Just (Entity _ (Car make model))) = Car make model convert _ = error "The database preconditions have been violated!" @ == Times with timezones Storing times with timezones in one type in databases is not possible, although it seems that it should be possible (@timezone@ and @timezonetz@ in PostgreSQL). That's why starting with persistent 2.0, all times will be mapped to @UTCTime@. If you need to store timezone information along with times in a database, store the timezone in a second field. Here are some links about the topic with further information: * https://github.com/yesodweb/persistent/issues/290 * https://groups.google.com/forum/#!msg/yesodweb/MIfcV2bwM80/8QLFpgp1LykJ * http://stackoverflow.com/questions/14615271/postgres-timestamp/14616640#14616640 * http://justatheory.com/computers/databases/postgresql/use-timestamptz.html * https://github.com/lpsmith/postgresql-simple/issues/69 * https://github.com/nikita-volkov/hasql-postgres/issues/1 = Conversion table (migrations) Here are the conversions between Haskell types and database types: +------------+----------------------+-------------------+---------------+----------------+ | Haskell | PostgreSQL | MySQL | MongoDB | SQLite | +============+======================+===================+===============+================+ | Text | VARCHAR | TEXT | String | VARCHAR | +------------+----------------------+-------------------+---------------+----------------+ | ByteString | BYTEA | BLOB | BinData | BLOB | +------------+----------------------+-------------------+---------------+----------------+ | Int | INT8 | BIGINT(20) | NumberLong | INTEGER | +------------+----------------------+-------------------+---------------+----------------+ | Double | DOUBLE PRECISION | DOUBLE | Double | REAL | +------------+----------------------+-------------------+---------------+----------------+ | Rational | NUMERIC(22, 12) | DECIMAL(32,20) | *Unsupported* | NUMERIC(32,20)| +------------+----------------------+-------------------+---------------+----------------+ | Bool | BOOLEAN | TINYINT(1) | Boolean | BOOLEAN | +------------+----------------------+-------------------+---------------+----------------+ | Day | DATE | DATE | NumberLong | DATE | +------------+----------------------+-------------------+---------------+----------------+ | TimeOfDay | TIME | TIME\*\* | *Unsupported* | TIME | +------------+----------------------+-------------------+---------------+----------------+ | UTCTime\* | TIMESTAMP | DATETIME\*\* | Date | TIMESTAMP | +------------+----------------------+-------------------+---------------+----------------+ Notes: \* Support for @ZonedTime@ was dropped in persistent 2.0. @UTCTime@ can be used with @timestamp without timezone@ and @timestamp with timezone@ in PostgreSQL. See also the section "Times with timezones". \*\* The default resolution for @TIME@ and @DATETIME@ in MySQL is one second. As of MySQL version 5.6.4, and persistent-mysql-2.6.2, fractional seconds are handled correctly if you declare an explicit precision by using @sqltype@. For example, appending @sqltype=TIME(6)@ to a @TimeOfDay@ field definition will give microsecond resolution. = Compatibility tables MySQL: +-------------------+-----------------------------------------------------------------------+ |Haskell type | Compatible MySQL types | +===================+=======================================================================+ | Bool | Tiny | +-------------------+-----------------------------------------------------------------------+ | Int8 | Tiny | +-------------------+-----------------------------------------------------------------------+ | Int16 | Tiny,Short | +-------------------+-----------------------------------------------------------------------+ | Int32 | Tiny,Short,Int24,Long | +-------------------+-----------------------------------------------------------------------+ | Int | Tiny,Short,Int24,Long,LongLong\* | +-------------------+-----------------------------------------------------------------------+ | Int64 | Tiny,Short,Int24,Long,LongLong | +-------------------+-----------------------------------------------------------------------+ | Integer | Tiny,Short,Int24,Long,LongLong | +-------------------+-----------------------------------------------------------------------+ | Word8 | Tiny | +-------------------+-----------------------------------------------------------------------+ | Word16 | Tiny,Short | +-------------------+-----------------------------------------------------------------------+ | Word32 | Tiny,Short,Int24,Long | +-------------------+-----------------------------------------------------------------------+ | Word64 | Tiny,Short,Int24,Long,LongLong | | Double | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long | +-------------------+-----------------------------------------------------------------------+ | Ratio Integer | Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,Long,LongLong | +-------------------+-----------------------------------------------------------------------+ | ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-------------------+-----------------------------------------------------------------------+ | Lazy.ByteString | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-------------------+-----------------------------------------------------------------------+ | Encoding.Text\*\* | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-------------------+-----------------------------------------------------------------------+ | Lazy.Text | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-------------------+-----------------------------------------------------------------------+ | [Char]/String | VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,Set,Enum | +-------------------+-----------------------------------------------------------------------+ | UTCTime | DateTime,Timestamp | +-------------------+-----------------------------------------------------------------------+ | Day | Year,Date,NewDate | +-------------------+-----------------------------------------------------------------------+ | TimeOfDay | Time | +-------------------+-----------------------------------------------------------------------+ \* When @Word@ size is 64bit \*\* Utf8 only Unsupported types: +--------------------------------------------------------------------+ | Not currently supported | +====================================================================+ | Word | +--------------------------------------------------------------------+ | Float | +--------------------------------------------------------------------+ | Scientific | +--------------------------------------------------------------------+ See . -} 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 } persistent-2.14.6.0/Database/Persist/Quasi/Internal.hs0000644000000000000000000014341514507117603020673 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | This @Internal@ module may have breaking changes that will not be reflected -- in major version bumps. Please use "Database.Persist.Quasi" instead. If you -- need something in this module, please file an issue on GitHub. -- -- @since 2.13.0.0 module Database.Persist.Quasi.Internal ( parse , PersistSettings (..) , upperCaseSettings , lowerCaseSettings , toFKNameInfixed , Token (..) , Line (..) , preparse , parseLine , parseFieldType , associateLines , LinesWithComments(..) , parseEntityFields , takeColsEx -- * UnboundEntityDef , UnboundEntityDef(..) , getUnboundEntityNameHS , unbindEntityDef , getUnboundFieldDefs , UnboundForeignDef(..) , getSqlNameOr , UnboundFieldDef(..) , UnboundCompositeDef(..) , UnboundIdDef(..) , unbindFieldDef , isUnboundFieldNullable , unboundIdDefToFieldDef , PrimarySpec(..) , mkAutoIdField' , UnboundForeignFieldList(..) , ForeignFieldReference(..) , mkKeyConType , isHaskellUnboundField , FieldTypeLit(..) ) where import Prelude hiding (lines) import Control.Applicative (Alternative((<|>))) import Control.Monad import Data.Char (isDigit, isLower, isSpace, isUpper, toLower) import Data.List (find, foldl') 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.Types import Database.Persist.Types.Base import Language.Haskell.TH.Syntax (Lift) import qualified Text.Read as R data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show parseFieldType :: Text -> Either String FieldType parseFieldType t0 = case parseApplyFT t0 of PSSuccess ft t' | T.all isSpace t' -> Right ft PSFail err -> Left $ "PSFail " ++ err other -> Left $ show other where parseApplyFT :: Text -> ParseState FieldType parseApplyFT t = case goMany id t of PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' PSSuccess [] _ -> PSFail "empty" PSFail err -> PSFail err PSDone -> PSDone parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType parseEnclosed end ftMod t = let (a, b) = T.break (== end) t in case parseApplyFT a of PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `Data.Monoid.mappend` t') (x, y) -> PSFail $ show (b, x, y) x -> PSFail $ show x parse1 :: Text -> ParseState FieldType parse1 t = fromMaybe (PSFail (show t)) $ do case T.uncons t of Nothing -> pure PSDone Just (x, xs) -> parseSpace x xs <|> parseParenEnclosed x xs <|> parseList x xs <|> parseNumericLit x xs <|> parseTextLit x xs <|> parseTypeCon x xs parseSpace :: Char -> Text -> Maybe (ParseState FieldType) parseSpace c t = do guard (isSpace c) pure $ parse1 (T.dropWhile isSpace t) parseParenEnclosed c t = do guard (c == '(') pure $ parseEnclosed ')' id t parseList c t = do guard (c == '[') pure $ parseEnclosed ']' FTList t parseTextLit :: Char -> Text -> Maybe (ParseState FieldType) parseTextLit c t = do guard (c == '"') let (a, b) = T.break (== '"') t lit = FTLit (TextTypeLit a) pure $ PSSuccess lit (T.drop 1 b) parseNumericLit :: Char -> Text -> Maybe (ParseState FieldType) parseNumericLit c t = do guard (isDigit c && T.all isDigit t) let (a, b) = breakAtNextSpace t lit <- FTLit . IntTypeLit <$> readMaybe (T.cons c a) pure $ PSSuccess lit b parseTypeCon c t = do guard (isUpper c || c == '\'') let (a, b) = breakAtNextSpace t pure $ PSSuccess (parseFieldTypePiece c a) b goMany :: ([FieldType] -> a) -> Text -> ParseState a goMany front t = case parse1 t of PSSuccess x t' -> goMany (front . (x:)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t breakAtNextSpace :: Text -> (Text, Text) breakAtNextSpace = T.break isSpace parseFieldTypePiece :: Char -> Text -> FieldType parseFieldTypePiece fstChar rest = case fstChar of '\'' -> FTTypePromoted rest _ -> let t = T.cons fstChar rest in case T.breakOnEnd "." t of (_, "") -> FTTypeCon Nothing t ("", _) -> FTTypeCon Nothing t (a, b) -> FTTypeCon (Just $ T.init a) b data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) -- ^ Modify the Haskell-style name into a database-style name. , psToFKName :: !(EntityNameHS -> ConstraintNameHS -> Text) -- ^ A function for generating the constraint name, with access to -- the entity and constraint names. Default value: @mappend@ -- -- @since 2.13.0.0 , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- -- @since 1.2 , psIdName :: !Text -- ^ The name of the id column. Default value: @id@ -- The name of the id column can also be changed on a per-model basis -- -- -- @since 2.0 } 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 } toFKNameInfixed :: Text -> EntityNameHS -> ConstraintNameHS -> Text toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) = entName <> inf <> conName -- | 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 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] } entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) entityNamesFromParsedDef ps parsedEntDef = (entNameHS, entNameDB) where entNameHS = parsedEntityDefEntityName parsedEntDef entNameDB = EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef) toParsedEntityDef :: LinesWithComments -> ParsedEntityDef toParsedEntityDef lwc = ParsedEntityDef { parsedEntityDefComments = lwcComments lwc , parsedEntityDefEntityName = entNameHS , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entAttribs , parsedEntityDefFieldAttributes = attribs , parsedEntityDefExtras = extras } 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 -- | An 'EntityDef' produced by the QuasiQuoter. It contains information that -- the QuasiQuoter is capable of knowing about the entities. It is inherently -- unfinished, though - there are many other @Unbound@ datatypes that also -- contain partial information. -- -- The 'unboundEntityDef' is not complete or reliable - to know which fields are -- safe to use, consult the parsing code. -- -- This type was completely internal until 2.13.0.0, when it was exposed as part -- of the "Database.Persist.Quasi.Internal" module. -- -- TODO: refactor this so we can expose it for consumers. -- -- @since 2.13.0.0 data UnboundEntityDef = UnboundEntityDef { unboundForeignDefs :: [UnboundForeignDef] -- ^ A list of foreign definitions on the parsed entity. -- -- @since 2.13.0.0 , unboundPrimarySpec :: PrimarySpec -- ^ The specification for the primary key of the unbound entity. -- -- @since 2.13.0.0 , unboundEntityDef :: EntityDef -- ^ The incomplete and partial 'EntityDef' that we're defining. We re-use -- the type here to prevent duplication, but several of the fields are unset -- and left to defaults. -- -- @since 2.13.0.0 , unboundEntityFields :: [UnboundFieldDef] -- ^ The list of fields for the entity. We're not capable of knowing -- information like "is this a reference?" or "what's the underlying type of -- the field?" yet, so we defer those to the Template Haskell execution. -- -- @since 2.13.0.0 } deriving (Eq, Ord, Show, Lift) -- | Convert an 'EntityDef' into an 'UnboundEntityDef'. This "forgets" -- information about the 'EntityDef', but it is all kept present on the -- 'unboundEntityDef' field if necessary. -- -- @since 2.13.0.0 unbindEntityDef :: EntityDef -> UnboundEntityDef unbindEntityDef ed = UnboundEntityDef { unboundForeignDefs = map unbindForeignDef (entityForeigns ed) , unboundPrimarySpec = case entityId ed of EntityIdField fd -> SurrogateKey (unbindIdDef (entityHaskell ed) fd) EntityIdNaturalKey cd -> NaturalKey (unbindCompositeDef cd) , unboundEntityDef = ed , unboundEntityFields = map unbindFieldDef (entityFields ed) } -- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns -- all fields defined on the entity. -- -- @since 2.13.0.0 getUnboundFieldDefs :: UnboundEntityDef -> [UnboundFieldDef] getUnboundFieldDefs = unboundEntityFields -- | This function forgets information about the 'CompositeDef' so that it can -- be remembered through Template Haskell. -- -- @since 2.13.0.0 unbindCompositeDef :: CompositeDef -> UnboundCompositeDef unbindCompositeDef cd = UnboundCompositeDef { unboundCompositeCols = fmap fieldHaskell (compositeFields cd) , unboundCompositeAttrs = compositeAttrs cd } -- | A representation of a database column, with everything that can be known at -- parse time. -- -- @since 2.13.0.0 data UnboundFieldDef = UnboundFieldDef { unboundFieldNameHS :: FieldNameHS -- ^ The Haskell name of the field. This is parsed directly from the -- definition, and is used to generate the Haskell record field and the -- 'EntityField' definition. -- -- @since 2.13.0.0 , unboundFieldNameDB :: FieldNameDB -- ^ The database name of the field. By default, this is determined by the -- 'PersistSettings' record at parse time. You can customize this with -- a @sql=@ attribute: -- -- @ -- name Text sql=foo_name -- @ -- -- @since 2.13.0.0 , unboundFieldAttrs :: [FieldAttr] -- ^ The attributes present on the field. For rules on parsing and utility, -- see the comments on the datatype. -- -- @since 2.13.0.0 , unboundFieldStrict :: Bool -- ^ Whether or not the field should be strict in the generated Haskell -- code. -- -- @since 2.13.0.0 , unboundFieldType :: FieldType -- ^ The type of the field, as far as is known at parse time. -- -- The TemplateHaskell code will reconstruct a 'Type' out of this, but the -- names will be imported as-is. -- -- @since 2.13.0.0 , unboundFieldCascade :: FieldCascade -- ^ We parse if there's a 'FieldCascade' on the field. If the field is not -- a reference, this information is ignored. -- -- @ -- Post -- user UserId OnDeleteCascade -- @ -- -- @since 2.13.0.0 , unboundFieldGenerated :: Maybe Text -- ^ Contains an expression to generate the column. If this is present, then -- the column will not be written to the database, but generated by the -- expression every time. -- -- @ -- Item -- subtotal Int -- taxRate Rational -- total Int generated="subtotal * tax_rate" -- @ -- -- @since 2.13.0.0 , unboundFieldComments :: Maybe Text -- ^ Any comments present on the field. Documentation comments use -- a Haskell-like syntax, and must be present before the field in question. -- -- @ -- Post -- -- | This is the blog post title. -- title Text -- -- | You can have multi-line comments. -- -- | But each line must have the pipe character. -- author UserId -- @ -- -- @since 2.13.0.0 } deriving (Eq, Ord, Show, Lift) -- | Forget innformation about a 'FieldDef' so it can beused as an -- 'UnboundFieldDef'. -- -- @since 2.13.0.0 unbindFieldDef :: FieldDef -> UnboundFieldDef unbindFieldDef fd = UnboundFieldDef { unboundFieldNameHS = fieldHaskell fd , unboundFieldNameDB = fieldDB fd , unboundFieldAttrs = fieldAttrs fd , unboundFieldType = fieldType fd , unboundFieldStrict = fieldStrict fd , unboundFieldCascade = fieldCascade fd , unboundFieldComments = fieldComments fd , unboundFieldGenerated = fieldGenerated fd } isUnboundFieldNullable :: UnboundFieldDef -> IsNullable isUnboundFieldNullable = fieldAttrsContainsNullable . unboundFieldAttrs -- | The specification for how an entity's primary key should be formed. -- -- Persistent requires that every table have a primary key. By default, an -- implied ID is assigned, based on the 'mpsImplicitIdDef' field on -- 'MkPersistSettings'. Because we can't access that type at parse-time, we -- defer that decision until later. -- -- @since 2.13.0.0 data PrimarySpec = 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 deriving (Eq, Ord, Show, Lift) -- | Construct an entity definition. mkUnboundEntityDef :: PersistSettings -> ParsedEntityDef -- ^ parsed entity definition -> UnboundEntityDef mkUnboundEntityDef ps parsedEntDef = UnboundEntityDef { unboundForeignDefs = entityConstraintDefsForeignsList entityConstraintDefs , unboundPrimarySpec = case (idField, primaryComposite) of (Just {}, Just {}) -> error "Specified both an ID field and a Primary field" (Just a, Nothing) -> if unboundIdType a == Just (mkKeyConType (unboundIdEntityName a)) then DefaultKey (FieldNameDB $ psIdName ps) else SurrogateKey a (Nothing, Just a) -> NaturalKey a (Nothing, Nothing) -> DefaultKey (FieldNameDB $ psIdName ps) , unboundEntityFields = cols , unboundEntityDef = EntityDef { entityHaskell = entNameHS , entityDB = entNameDB -- idField is the user-specified Id -- otherwise useAutoIdField -- but, adjust it if the user specified a Primary , entityId = EntityIdField $ maybe autoIdField (unboundIdDefToFieldDef (defaultIdName ps) entNameHS) idField , entityAttrs = parsedEntityDefEntityAttributes parsedEntDef , entityFields = [] , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs , entityForeigns = [] , entityDerives = concat $ mapMaybe takeDerives textAttribs , entityExtra = parsedEntityDefExtras parsedEntDef , entitySum = parsedEntityDefIsSum parsedEntDef , entityComments = case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) } } where (entNameHS, entNameDB) = entityNamesFromParsedDef ps parsedEntDef attribs = parsedEntityDefFieldAttributes parsedEntDef textAttribs :: [[Text]] textAttribs = fmap tokenText <$> attribs entityConstraintDefs = foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs idField = case entityConstraintDefsIdField entityConstraintDefs of SetMoreThanOnce -> error "expected only one Id declaration per entity" SetOnce a -> Just a NotSet -> Nothing primaryComposite = case entityConstraintDefsPrimaryComposite entityConstraintDefs of SetMoreThanOnce -> error "expected only one Primary declaration per entity" SetOnce a -> Just a NotSet -> Nothing cols :: [UnboundFieldDef] cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs autoIdField :: FieldDef autoIdField = mkAutoIdField ps entNameHS idSqlType idSqlType :: SqlType idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite defaultIdName :: PersistSettings -> FieldNameDB defaultIdName = FieldNameDB . psIdName -- | Convert an 'UnboundIdDef' into a 'FieldDef' suitable for use in the -- 'EntityIdField' constructor. -- -- @since 2.13.0.0 unboundIdDefToFieldDef :: FieldNameDB -> EntityNameHS -> UnboundIdDef -> FieldDef unboundIdDefToFieldDef dbField entNameHS uid = FieldDef { fieldHaskell = FieldNameHS "Id" , fieldDB = getSqlNameOr dbField (unboundIdAttrs uid) , fieldType = fromMaybe (mkKeyConType entNameHS) $ unboundIdType uid , fieldSqlType = SqlOther "SqlType unset for Id" , fieldStrict = False , fieldReference = ForeignRef entNameHS , fieldAttrs = unboundIdAttrs uid , fieldComments = Nothing , fieldCascade = unboundIdCascade uid , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } -- | Convert an 'EntityNameHS' into 'FieldType' that will get parsed into the ID -- type for the entity. -- -- @ -- >>> mkKeyConType (EntityNameHS "Hello) -- FTTypeCon Nothing "HelloId" -- @ -- -- @since 2.13.0.0 mkKeyConType :: EntityNameHS -> FieldType mkKeyConType entNameHs = FTTypeCon Nothing (keyConName entNameHs) -- | Assuming that the provided 'FieldDef' is an ID field, this converts it into -- an 'UnboundIdDef'. -- -- @since 2.13.0.0 unbindIdDef :: EntityNameHS -> FieldDef -> UnboundIdDef unbindIdDef entityName fd = UnboundIdDef { unboundIdEntityName = entityName , unboundIdDBName = fieldDB fd , unboundIdAttrs = fieldAttrs fd , unboundIdCascade = fieldCascade fd , unboundIdType = Just $ fieldType fd } 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 { fieldHaskell = FieldNameHS "Id" , fieldDB = dbName , fieldType = FTTypeCon Nothing $ keyConName entName , fieldSqlType = idSqlType , fieldReference = NoReference , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing , fieldCascade = noCascade , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } keyConName :: EntityNameHS -> Text keyConName entName = unEntityNameHS entName `mappend` "Id" 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) takeColsEx :: PersistSettings -> [Text] -> Maybe UnboundFieldDef takeColsEx = takeCols (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr) takeCols :: (Text -> String -> Maybe UnboundFieldDef) -> PersistSettings -> [Text] -> Maybe UnboundFieldDef takeCols _ _ ("deriving":_) = Nothing takeCols onErr ps (n':typ:rest') | not (T.null n) && isLower (T.head n) = case parseFieldType typ of Left err -> onErr typ err Right ft -> Just UnboundFieldDef { unboundFieldNameHS = FieldNameHS n , unboundFieldNameDB = getDbName' ps n fieldAttrs_ , unboundFieldType = ft , unboundFieldAttrs = fieldAttrs_ , unboundFieldStrict = fromMaybe (psStrictFields ps) mstrict , unboundFieldComments = Nothing , unboundFieldCascade = cascade_ , unboundFieldGenerated = generated_ } where fieldAttrs_ = parseFieldAttrs attrs_ generated_ = parseGenerated attrs_ (cascade_, attrs_) = parseCascade rest' (mstrict, n) | Just x <- T.stripPrefix "!" n' = (Just True, x) | Just x <- T.stripPrefix "~" n' = (Just False, x) | otherwise = (Nothing, n') takeCols _ _ _ = Nothing parseGenerated :: [Text] -> Maybe Text parseGenerated = foldl' (\acc x -> acc <|> T.stripPrefix "generated=" x) Nothing getDbName :: PersistSettings -> Text -> [Text] -> Text getDbName ps n = fromMaybe (psToDBName ps n) . listToMaybe . mapMaybe (T.stripPrefix "sql=") getDbName' :: PersistSettings -> Text -> [FieldAttr] -> FieldNameDB getDbName' ps n = getSqlNameOr (FieldNameDB $ psToDBName ps n) getSqlNameOr :: FieldNameDB -> [FieldAttr] -> FieldNameDB getSqlNameOr def = maybe def FieldNameDB . findAttrSql where findAttrSql = listToMaybe . mapMaybe isAttrSql isAttrSql attr = case attr of FieldAttrSql t -> Just t _ -> Nothing data SetOnceAtMost a = NotSet | SetOnce a | SetMoreThanOnce instance Semigroup (SetOnceAtMost a) where a <> b = case (a, b) of (_, NotSet) -> a (NotSet, _) -> b (SetOnce _, SetOnce _) -> SetMoreThanOnce _ -> a instance Monoid (SetOnceAtMost a) where mempty = NotSet data EntityConstraintDefs = EntityConstraintDefs { entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef , entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef) , entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef) } instance Semigroup EntityConstraintDefs where a <> b = EntityConstraintDefs { entityConstraintDefsIdField = entityConstraintDefsIdField a <> entityConstraintDefsIdField b , entityConstraintDefsPrimaryComposite = entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b , entityConstraintDefsUniques = entityConstraintDefsUniques a <> entityConstraintDefsUniques b , entityConstraintDefsForeigns = entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b } instance Monoid EntityConstraintDefs where mempty = EntityConstraintDefs mempty mempty Nothing Nothing entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef] entityConstraintDefsUniquesList = foldMap NEL.toList . entityConstraintDefsUniques entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef] entityConstraintDefsForeignsList = foldMap NEL.toList . entityConstraintDefsForeigns takeConstraint :: PersistSettings -> EntityNameHS -> [UnboundFieldDef] -> NonEmpty Text -> EntityConstraintDefs takeConstraint ps entityName defs (n :| rest) = case n of "Unique" -> mempty { entityConstraintDefsUniques = pure <$> takeUniq ps (unEntityNameHS entityName) defs rest } "Foreign" -> mempty { entityConstraintDefsForeigns = Just $ pure (takeForeign ps entityName rest) } "Primary" -> let unboundComposite = takeComposite (unboundFieldNameHS <$> defs) rest in mempty { entityConstraintDefsPrimaryComposite = SetOnce unboundComposite , entityConstraintDefsUniques = Just $ pure $ compositeToUniqueDef entityName defs unboundComposite } "Id" -> mempty { entityConstraintDefsIdField = SetOnce (takeId ps entityName rest) } _ | isCapitalizedText n -> mempty { entityConstraintDefsUniques = pure <$> takeUniq ps "" defs (n : rest) } _ -> mempty -- | 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 takeId ps entityName texts = UnboundIdDef { unboundIdDBName = FieldNameDB $ psIdName ps , unboundIdEntityName = entityName , unboundIdCascade = cascade_ , unboundIdAttrs = parseFieldAttrs attrs_ , unboundIdType = typ } where typ = case texts of [] -> Nothing (t : _) -> case parseFieldType t of Left _ -> Nothing Right ft -> Just ft (cascade_, attrs_) = parseCascade texts -- | A definition for a composite primary key. -- -- @since.2.13.0.0 data UnboundCompositeDef = UnboundCompositeDef { unboundCompositeCols :: NonEmpty FieldNameHS -- ^ The field names for the primary key. -- -- @since 2.13.0.0 , unboundCompositeAttrs :: [Attr] -- ^ A list of attributes defined on the primary key. This is anything that -- occurs after a @!@ character. -- -- @since 2.13.0.0 } deriving (Eq, Ord, Show, Lift) compositeToUniqueDef :: EntityNameHS -> [UnboundFieldDef] -> UnboundCompositeDef -> UniqueDef compositeToUniqueDef entityName fields UnboundCompositeDef {..} = UniqueDef { uniqueHaskell = ConstraintNameHS (unEntityNameHS entityName <> "PrimaryKey") , uniqueDBName = ConstraintNameDB "primary_key" , uniqueFields = fmap (\hsName -> (hsName, getDbNameFor hsName)) unboundCompositeCols , uniqueAttrs = unboundCompositeAttrs } where getDbNameFor hsName = case mapMaybe (matchHsName hsName) fields of [] -> error "Unable to find `hsName` in fields" (a : _) -> a matchHsName hsName UnboundFieldDef {..} = do guard $ unboundFieldNameHS == hsName pure unboundFieldNameDB takeComposite :: [FieldNameHS] -> [Text] -> UnboundCompositeDef takeComposite fields pkcols = UnboundCompositeDef { unboundCompositeCols = fmap (getDef fields) neCols , unboundCompositeAttrs = attrs } where neCols = case NEL.nonEmpty cols of Nothing -> error "No fields provided for primary key" Just xs -> xs (cols, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t getDef (d:ds) t | d == FieldNameHS t = -- TODO: check for nullability in later step -- if nullable (fieldAttrs d) /= NotNullable -- then error $ "primary key column cannot be nullable: " ++ show t ++ show fields d | otherwise = getDef ds t -- Unique UppercaseConstraintName list of lowercasefields terminated -- by ! or sql= such that a unique constraint can look like: -- `UniqueTestNull fieldA fieldB sql=ConstraintNameInDatabase !force` -- Here using sql= sets the name of the constraint. takeUniq :: PersistSettings -> Text -> [UnboundFieldDef] -> [Text] -> Maybe UniqueDef takeUniq ps tableName defs (n : rest) | isCapitalizedText n = do fields <- mfields pure UniqueDef { uniqueHaskell = ConstraintNameHS n , uniqueDBName = dbName , uniqueFields = fmap (\a -> (FieldNameHS a, getDBName defs a)) fields , uniqueAttrs = attrs } where isAttr a = "!" `T.isPrefixOf` a isSqlName a = "sql=" `T.isPrefixOf` a isNonField a = isAttr a || isSqlName a (fieldsList, nonFields) = break isNonField rest mfields = NEL.nonEmpty fieldsList attrs = filter isAttr nonFields usualDbName = ConstraintNameDB $ psToDBName ps (tableName `T.append` n) sqlName :: Maybe ConstraintNameDB sqlName = case find isSqlName nonFields of Nothing -> Nothing (Just t) -> case drop 1 $ T.splitOn "=" t of (x : _) -> Just (ConstraintNameDB x) _ -> Nothing dbName = fromMaybe usualDbName sqlName getDBName [] t = error $ T.unpack (unknownUniqueColumnError t defs n) getDBName (d:ds) t | unboundFieldNameHS d == FieldNameHS t = unboundFieldNameDB d | otherwise = getDBName ds t takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs unknownUniqueColumnError :: Text -> [UnboundFieldDef] -> Text -> Text unknownUniqueColumnError t defs n = "Unknown column in \"" <> n <> "\" constraint: \"" <> t <> "\"" <> " possible fields: " <> T.pack (show (toFieldName <$> defs)) where toFieldName :: UnboundFieldDef -> Text toFieldName fd = unFieldNameHS (unboundFieldNameHS fd) -- | Define an explicit foreign key reference. -- -- @ -- User -- name Text -- email Text -- -- Primary name email -- -- Dog -- ownerName Text -- ownerEmail Text -- -- Foreign User fk_dog_user ownerName ownerEmail -- @ -- -- @since 2.13.0.0 data UnboundForeignDef = UnboundForeignDef { unboundForeignFields :: UnboundForeignFieldList -- ^ Fields in the source entity. -- -- @since 2.13.0.0 , unboundForeignDef :: ForeignDef -- ^ The 'ForeignDef' which needs information filled in. -- -- This value is unreliable. See the parsing code to see what data is filled -- in here. -- -- @since 2.13.0.0 } deriving (Eq, Ord, Show, Lift) -- | A list of fields present on the foreign reference. data UnboundForeignFieldList = 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 deriving (Eq, Ord, Show, Lift) -- | A pairing of the 'FieldNameHS' for the source table to the 'FieldNameHS' -- for the target table. -- -- @since 2.13.0.0 data ForeignFieldReference = ForeignFieldReference { ffrSourceField :: FieldNameHS -- ^ The column on the source table. -- -- @since 2.13.0.0 , ffrTargetField :: FieldNameHS -- ^ The column on the target table. -- -- @since 2.13.0.0 } deriving (Eq, Ord, Show, Lift) unbindForeignDef :: ForeignDef -> UnboundForeignDef unbindForeignDef fd = UnboundForeignDef { unboundForeignFields = FieldListHasReferences $ NEL.fromList $ fmap mk (foreignFields fd) , unboundForeignDef = fd } where mk ((fH, _), (pH, _)) = ForeignFieldReference { ffrSourceField = fH , ffrTargetField = pH } mkUnboundForeignFieldList :: [Text] -> [Text] -> Either String UnboundForeignFieldList mkUnboundForeignFieldList (fmap FieldNameHS -> source) (fmap FieldNameHS -> target) = case NEL.nonEmpty source of Nothing -> Left "No fields on foreign reference." Just sources -> case NEL.nonEmpty target of Nothing -> Right $ FieldListImpliedId sources Just targets -> if length targets /= length sources then Left "Target and source length differe on foreign reference." else Right $ FieldListHasReferences $ NEL.zipWith ForeignFieldReference sources targets takeForeign :: PersistSettings -> EntityNameHS -> [Text] -> UnboundForeignDef takeForeign ps entityName = takeRefTable where errorPrefix :: String errorPrefix = "invalid foreign key constraint on table[" ++ show (unEntityNameHS entityName) ++ "] " takeRefTable :: [Text] -> UnboundForeignDef takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name" takeRefTable (refTableName:restLine) = go restLine Nothing Nothing where go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef go (constraintNameText:rest) onDelete onUpdate | not (T.null constraintNameText) && isLower (T.head constraintNameText) = UnboundForeignDef { unboundForeignFields = either error id $ mkUnboundForeignFieldList foreignFields parentFields , unboundForeignDef = ForeignDef { foreignRefTableHaskell = EntityNameHS refTableName , foreignRefTableDBName = EntityNameDB $ psToDBName ps refTableName , foreignConstraintNameHaskell = constraintName , foreignConstraintNameDBName = toFKConstraintNameDB ps entityName constraintName , foreignFieldCascade = FieldCascade { fcOnDelete = onDelete , fcOnUpdate = onUpdate } , foreignAttrs = attrs , foreignFields = [] , foreignNullable = False , foreignToPrimary = null parentFields } } where constraintName = ConstraintNameHS constraintNameText (fields, attrs) = break ("!" `T.isPrefixOf`) rest (foreignFields, parentFields) = case break (== "References") fields of (ffs, []) -> (ffs, []) (ffs, _ : pfs) -> case (length ffs, length pfs) of (flen, plen) | flen == plen -> (ffs, pfs) (flen, plen) -> error $ errorPrefix ++ concat [ "Found " , show flen , " foreign fields but " , show plen, " parent fields" ] go ((parseCascadeAction CascadeDelete -> Just cascadingAction) : rest) onDelete' onUpdate = case onDelete' of Nothing -> go rest (Just cascadingAction) onUpdate Just _ -> error $ errorPrefix ++ "found more than one OnDelete actions" go ((parseCascadeAction CascadeUpdate -> Just cascadingAction) : rest) onDelete onUpdate' = case onUpdate' of Nothing -> go rest onDelete (Just cascadingAction) Just _ -> error $ errorPrefix ++ "found more than one OnUpdate actions" go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs toFKConstraintNameDB :: PersistSettings -> EntityNameHS -> ConstraintNameHS -> ConstraintNameDB toFKConstraintNameDB ps entityName constraintName = ConstraintNameDB $ psToDBName ps (psToFKName ps entityName constraintName) data CascadePrefix = CascadeUpdate | CascadeDelete parseCascade :: [Text] -> (FieldCascade, [Text]) parseCascade allTokens = go [] Nothing Nothing allTokens where go acc mupd mdel tokens_ = case tokens_ of [] -> ( FieldCascade { fcOnDelete = mdel , fcOnUpdate = mupd } , acc ) this : rest -> case parseCascadeAction CascadeUpdate this of Just cascUpd -> case mupd of Nothing -> go acc (Just cascUpd) mdel rest Just _ -> nope "found more than one OnUpdate action" Nothing -> case parseCascadeAction CascadeDelete this of Just cascDel -> case mdel of Nothing -> go acc mupd (Just cascDel) rest Just _ -> nope "found more than one OnDelete action" Nothing -> go (this : acc) mupd mdel rest nope msg = error $ msg <> ", tokens: " <> show allTokens parseCascadeAction :: CascadePrefix -> Text -> Maybe CascadeAction parseCascadeAction prfx text = do cascadeStr <- T.stripPrefix ("On" <> toPrefix prfx) text readMaybe cascadeStr where toPrefix cp = case cp of CascadeUpdate -> "Update" CascadeDelete -> "Delete" takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing -- | Returns 'True' if the 'UnboundFieldDef' does not have a 'MigrationOnly' or -- 'SafeToRemove' flag from the QuasiQuoter. -- -- @since 2.13.0.0 isHaskellUnboundField :: UnboundFieldDef -> Bool isHaskellUnboundField fd = FieldAttrMigrationOnly `notElem` unboundFieldAttrs fd && FieldAttrSafeToRemove `notElem` unboundFieldAttrs fd -- | Return the 'EntityNameHS' for an 'UnboundEntityDef'. -- -- @since 2.13.0.0 getUnboundEntityNameHS :: UnboundEntityDef -> EntityNameHS getUnboundEntityNameHS = entityHaskell . unboundEntityDef readMaybe :: Read a => Text -> Maybe a readMaybe = R.readMaybe . T.unpack persistent-2.14.6.0/Database/Persist/Sql.hs0000644000000000000000000001001514476403105016561 0ustar0000000000000000-- | This module is the primary entry point if you're working with @persistent@ -- on a SQL database. -- -- = Getting Started -- -- First, you'll want to define your database entities. You can do that with -- "Database.Persist.Quasi." -- -- Then, you'll use the operations module Database.Persist.Sql ( -- * 'RawSql' and 'PersistFieldSql' module Database.Persist.Sql.Class -- * Running actions -- | Run actions in a transaction with 'runSqlPool'. , module Database.Persist.Sql.Run -- * Migrations , module Database.Persist.Sql.Migration -- * @persistent@ combinators -- | We re-export "Database.Persist" here, to make it easier to use query -- and update combinators. Check out that module for documentation. , module Database.Persist , module Database.Persist.Sql.Orphan.PersistStore -- * The Escape Hatch -- | @persistent@ offers a set of functions that are useful for operating -- directly on the underlying SQL database. This can allow you to use -- whatever SQL features you want. -- -- Consider going to for a more powerful SQL query library built on @persistent@. , rawQuery , rawQueryRes , rawExecute , rawExecuteCount , rawSql -- * SQL helpers , deleteWhereCount , updateWhereCount , filterClause , filterClauseWithVals , orderClause , FilterTablePrefix (..) -- * Transactions , transactionSave , transactionSaveWithIsolation , transactionUndo , transactionUndoWithIsolation -- * Other utilities , getStmtConn , mkColumns , BackendSpecificOverrides , emptyBackendSpecificOverrides , getBackendSpecificForeignKeyName , setBackendSpecificForeignKeyName , defaultAttribute -- * Internal , IsolationLevel(..) , decorateSQLWithLimitOffset , module Database.Persist.Sql.Types ) where import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask) import Database.Persist import Database.Persist.Sql.Class import Database.Persist.Sql.Internal import Database.Persist.Sql.Migration import Database.Persist.Sql.Raw import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal (IsolationLevel(..), SqlBackend(..)) import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore import Database.Persist.Sql.Orphan.PersistUnique () -- | Commit the current transaction and begin a new one. -- This is used when a transaction commit is required within the context of 'runSqlConn' -- (which brackets its provided action with a transaction begin/commit pair). -- -- @since 1.2.0 transactionSave :: MonadIO m => ReaderT SqlBackend m () transactionSave = do conn <- ask 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 isolation = do conn <- ask let getter = getStmtConn conn liftIO $ connCommit conn getter >> connBegin conn getter (Just isolation) -- | Roll back the current transaction and begin a new one. -- This rolls back to the state of the last call to 'transactionSave' or the enclosing -- 'runSqlConn' call. -- -- @since 1.2.0 transactionUndo :: MonadIO m => ReaderT SqlBackend m () transactionUndo = do conn <- ask 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 isolation = do conn <- ask let getter = getStmtConn conn liftIO $ connRollback conn getter >> connBegin conn getter (Just isolation) persistent-2.14.6.0/Database/Persist/Sql/Migration.hs0000644000000000000000000002524514476403105020525 0ustar0000000000000000-- | This module documents tools and utilities for running SQL migrations. -- -- A 'Migration' is (currently) an alias for a 'WriterT' of module Database.Persist.Sql.Migration ( -- * Types Migration , CautiousMigration , Sql -- * Using a 'Migration' , showMigration , parseMigration , parseMigration' , printMigration , getMigration , runMigration , runMigrationQuiet , runMigrationSilent , runMigrationUnsafe , runMigrationUnsafeQuiet , migrate -- * Utilities for constructing migrations -- | While 'migrate' is capable of creating a 'Migration' for you, it's not -- the only way you can write migrations. You can use these utilities to write -- extra steps in your migrations. -- -- As an example, let's say we want to enable the @citext@ extension on -- @postgres@ as part of our migrations. -- -- @ -- 'Database.Persist.TH.share' ['Database.Persist.TH.mkPersist' sqlSettings, 'Database.Persist.TH.mkMigration' "migrateAll"] ... -- -- migration :: 'Migration' -- migration = do -- 'runSqlCommand' $ -- 'rawExecute_' "CREATE EXTENSION IF NOT EXISTS \"citext\";" -- migrateAll -- @ -- -- For raw commands, you can also just write 'addMigration': -- -- @ -- migration :: 'Migration' -- migration = do -- 'addMigration' "CREATE EXTENSION IF NOT EXISTS \"citext\";" -- migrateAll -- @ , reportErrors , reportError , addMigrations , addMigration , runSqlCommand -- * If something goes wrong... , PersistUnsafeMigrationException(..) ) where import Control.Exception (throwIO) import Control.Monad (liftM, unless) import Control.Monad.IO.Unlift import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Reader (ReaderT(..), ask) import Control.Monad.Trans.Writer import Data.Text (Text, isPrefixOf, pack, snoc, unpack) import qualified Data.Text.IO import GHC.Stack import System.IO import System.IO.Silently (hSilence) 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 -- | A list of SQL operations, marked with a safety flag. If the 'Bool' is -- 'True', then the operation is *unsafe* - it might be destructive, or -- otherwise not idempotent. If the 'Bool' is 'False', then the operation -- is *safe*, and can be run repeatedly without issues. type CautiousMigration = [(Bool, Sql)] -- | A 'Migration' is a four level monad stack consisting of: -- -- * @'WriterT' ['Text']@ representing a log of errors in the migrations. -- * @'WriterT' 'CautiousMigration'@ representing a list of migrations to -- run, along with whether or not they are safe. -- * @'ReaderT' 'SqlBackend'@, aka the 'SqlPersistT' transformer for -- database interop. -- * @'IO'@ for arbitrary IO. type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) () allSql :: CautiousMigration -> [Sql] allSql = map snd safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) -- | Given a 'Migration', this parses it and returns either a list of -- errors associated with the migration or a list of migrations to do. parseMigration :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration) parseMigration = liftIOReader . liftM go . runWriterT . execWriterT where go ([], sql) = Right sql go (errs, _) = Left errs liftIOReader (ReaderT m) = ReaderT $ liftIO . m -- | 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' m = do 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) -- | Convert a 'Migration' to a list of 'Text' values corresponding to their -- 'Sql' statements. 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 m = do 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 m = runMigration' m False >> return () -- | Same as 'runMigration', but does not report the individual migrations on -- stderr. Instead it returns a list of the executed SQL commands. -- -- This is a safer/more robust alternative to 'runMigrationSilent', but may be -- less silent for some persistent implementations, most notably -- persistent-postgresql -- -- @since 2.10.2 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 -- instead of printing them to stderr. -- -- This function silences the migration by remapping 'stderr'. As a result, it -- 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 m = withRunInIO $ \run -> hSilence [stderr] $ run $ runMigration' m True -- | Run the given migration against the database. If the migration fails -- to parse, or there are any unsafe migrations, then this will error at -- runtime. This returns a list of the migrations that were executed. runMigration' :: (HasCallStack, MonadIO m) => Migration -> Bool -- ^ is silent? -> ReaderT SqlBackend m [Text] runMigration' m silent = do mig <- parseMigration' m if any fst mig then liftIO . throwIO $ PersistUnsafeMigrationException mig else mapM (executeMigrate silent) $ sortMigrations $ safeSql mig -- | Like 'runMigration', but this will perform the unsafe database -- migrations instead of erroring out. 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 = runMigrationUnsafe' True 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 silent s = do unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s rawExecute s [] return s -- | Sort the alter DB statements so tables are created before constraints are -- added. sortMigrations :: [Sql] -> [Sql] sortMigrations x = filter isCreate x ++ filter (not . isCreate) x where -- Note the use of lower-case e. This (hack) allows backends to explicitly -- choose to have this special sorting applied. isCreate t = pack "CREATe " `isPrefixOf` t -- | 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 allDefs val = do conn <- lift $ lift ask res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val either reportErrors addMigrations res -- | Report a single error in a 'Migration'. -- -- @since 2.9.2 reportError :: Text -> Migration reportError = tell . pure -- | Report multiple errors in a 'Migration'. -- -- @since 2.9.2 reportErrors :: [Text] -> Migration reportErrors = tell -- | Add a migration to the migration plan. -- -- @since 2.9.2 addMigration :: Bool -- ^ Is the migration unsafe to run? (eg a destructive or non-idempotent -- update on the schema). If 'True', the migration is *unsafe*, and will -- need to be run manually later. If 'False', the migration is *safe*, and -- can be run any number of times. -> Sql -- ^ A 'Text' value representing the command to run on the database. -> Migration addMigration isUnsafe sql = lift (tell [(isUnsafe, sql)]) -- | Add a 'CautiousMigration' (aka a @[('Bool', 'Text')]@) to the -- migration plan. -- -- @since 2.9.2 addMigrations :: CautiousMigration -> Migration addMigrations = lift . tell -- | Run an action against the database during a migration. Can be useful for eg -- creating Postgres extensions: -- -- @ -- runSqlCommand $ 'rawExecute' "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" [] -- @ -- -- @since 2.13.0.0 runSqlCommand :: SqlPersistT IO () -> Migration runSqlCommand = lift . lift -- | An exception indicating that Persistent refused to run some unsafe -- migrations. Contains a list of pairs where the Bool tracks whether the -- migration was unsafe (True means unsafe), and the Sql is the sql statement -- for the migration. -- -- @since 2.11.1.0 newtype PersistUnsafeMigrationException = PersistUnsafeMigrationException [(Bool, Sql)] -- | This 'Show' instance renders an error message suitable for printing to the -- console. This is a little dodgy, but since GHC uses Show instances when -- displaying uncaught exceptions, we have little choice. instance Show PersistUnsafeMigrationException where show (PersistUnsafeMigrationException mig) = concat [ "\n\nDatabase migration: manual intervention required.\n" , "The unsafe actions are prefixed by '***' below:\n\n" , unlines $ map displayMigration mig ] where displayMigration :: (Bool, Sql) -> String displayMigration (True, s) = "*** " ++ unpack s ++ ";" displayMigration (False, s) = " " ++ unpack s ++ ";" instance Exception PersistUnsafeMigrationException persistent-2.14.6.0/Database/Persist/Sql/Types/Internal.hs0000644000000000000000000001014414476403105021444 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -- | Breaking changes to this module are not reflected in the major version -- number. Prefer to import from "Database.Persist.Sql" instead. If you neeed -- something from this module, please file an issue on GitHub. module Database.Persist.Sql.Types.Internal ( HasPersistBackend (..) , IsPersistBackend (..) , SqlReadBackend (..) , SqlWriteBackend (..) , readToUnknown , readToWrite , writeToUnknown , LogFunc , InsertSqlResult (..) , Statement (..) , IsolationLevel (..) , makeIsolationLevelStatement , SqlBackend (..) , SqlBackendCanRead , SqlBackendCanWrite , SqlReadT , SqlWriteT , IsSqlBackend , SqlBackendHooks (..) ) where import Control.Monad.Trans.Class (lift) 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(..)) import Database.Persist.SqlBackend.Internal import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.SqlBackend.Internal.MkSqlBackend import Database.Persist.SqlBackend.Internal.Statement -- | An SQL backend which can only handle read queries -- -- The constructor was exposed in 2.10.0. newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend persistBackend = unSqlReadBackend instance IsPersistBackend SqlReadBackend where mkPersistBackend = SqlReadBackend -- | An SQL backend which can handle read or write queries -- -- The constructor was exposed in 2.10.0 newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } instance HasPersistBackend SqlWriteBackend where type BaseBackend SqlWriteBackend = SqlBackend persistBackend = unSqlWriteBackend instance IsPersistBackend SqlWriteBackend where mkPersistBackend = SqlWriteBackend -- | Useful for running a write query against an untagged backend with unknown capabilities. writeToUnknown :: Monad m => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a writeToUnknown ma = do 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 ma = do 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 ma = do 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 ) -- | 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 ) -- | 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 -- | 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 -- | A backend which is a wrapper around @SqlBackend@. type IsSqlBackend backend = ( IsPersistBackend backend , BaseBackend backend ~ SqlBackend ) persistent-2.14.6.0/Database/Persist/Sql/Util.hs0000644000000000000000000002200114507117603017474 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Database.Persist.Sql.Util ( parseEntityValues , keyAndEntityColumnNames , entityColumnCount , isIdField , hasNaturalKey , hasCompositePrimaryKey , dbIdColumns , dbIdColumnsEsc , dbColumns , updateFieldDef , updatePersistValue , mkUpdateText , mkUpdateText' , commaSeparated , parenWrapped , mkInsertValues , mkInsertPlaceholders , parseExistsResult ) where import Data.ByteString.Char8 (readInteger) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Maybe as Maybe import Data.Text (Text, pack) import qualified Data.Text as T import Database.Persist ( Entity(Entity) , EntityDef , EntityField , 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(..)) 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 -- | Returns 'True' if the entity has a natural key defined with the -- Primary keyword. -- -- A natural key is a key that is inherent to the record, and is part of -- the actual Haskell record. The opposite of a natural key is a "surrogate -- key", which is not part of the normal domain object. Automatically -- generated ID columns are the most common surrogate ID, while an email -- address is a common natural key. -- -- @ -- User -- email String -- name String -- Primary email -- -- Person -- Id UUID -- name String -- -- Follower -- name String -- @ -- -- Given these entity definitions, @User@ would return 'True', because the -- @Primary@ keyword sets the @email@ column to be the primary key. The -- generated Haskell type would look like this: -- -- @ -- data User = User -- { userEmail :: String -- , userName :: String -- } -- @ -- -- @Person@ would be false. While the @Id@ syntax allows you to define -- a custom ID type for an entity, the @Id@ column is a surrogate key. -- -- The same is true for @Follower@. The automatically generated -- autoincremented integer primary key is a surrogate key. -- -- There's nothing preventing you from defining a @Primary@ definition that -- refers to a surrogate key. This is totally fine. -- -- @since 2.11.0 hasNaturalKey :: EntityDef -> Bool hasNaturalKey = Maybe.isJust . entityPrimary -- | Returns 'True' if the provided entity has a custom composite primary -- key. Composite keys have multiple fields in them. -- -- @ -- User -- email String -- name String -- Primary userId -- -- Profile -- personId PersonId -- email String -- Primary personId email -- -- Person -- Id UUID -- name String -- -- Follower -- name String -- @ -- -- Given these entity definitions, only @Profile@ would return 'True', -- because it is the only entity with multiple columns in the primary key. -- @User@ has a single column natural key. @Person@ has a custom single -- column surrogate key defined with @Id@. And @Follower@ has a default -- single column surrogate key. -- -- @since 2.11.0 hasCompositePrimaryKey :: EntityDef -> Bool hasCompositePrimaryKey ed = case entityPrimary ed of Just cdef -> case compositeFields cdef of (_ :| _ : _) -> True _ -> False Nothing -> False dbIdColumns :: SqlBackend -> EntityDef -> NonEmpty Text dbIdColumns conn = dbIdColumnsEsc (connEscapeFieldName conn) dbIdColumnsEsc :: (FieldNameDB -> Text) -> EntityDef -> NonEmpty Text dbIdColumnsEsc esc t = fmap (esc . fieldDB) $ getEntityKeyFields t dbColumns :: SqlBackend -> EntityDef -> NonEmpty Text dbColumns conn = fmap escapeColumn . keyAndEntityFields where escapeColumn = connEscapeFieldName conn . fieldDB 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 where 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 Right key -> Right (Entity key xs') isIdField :: forall record typ. (PersistEntity record) => EntityField record typ -> Bool isIdField f = fieldHaskell (persistFieldDef f) == FieldNameHS "Id" -- | Gets the 'FieldDef' for an 'Update'. updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f updateFieldDef BackendUpdate {} = error "updateFieldDef: did not expect BackendUpdate" updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v updatePersistValue (BackendUpdate{}) = error "updatePersistValue: did not expect BackendUpdate" commaSeparated :: [Text] -> Text commaSeparated = T.intercalate ", " 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' 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" where n = escapeName . fieldDB . updateFieldDef $ x parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] -- | Make a list 'PersistValue' suitable for database inserts. Pairs nicely -- with the function 'mkInsertPlaceholders'. -- -- Does not include generated columns. -- -- @since 2.11.0.0 mkInsertValues :: PersistEntity rec => rec -> [PersistValue] mkInsertValues entity = Maybe.catMaybes . zipWith redactGeneratedCol (getEntityFields . entityDef $ Just entity) $ toPersistFields entity where redactGeneratedCol fd pv = case fieldGenerated fd of Nothing -> Just pv Just _ -> Nothing -- | Returns a list of escaped field names and @"?"@ placeholder values for -- performing inserts. This does not include generated columns. -- -- Does not include generated columns. -- -- @since 2.11.0.0 mkInsertPlaceholders :: EntityDef -> (FieldNameDB -> Text) -- ^ An `escape` function -> [(Text, Text)] mkInsertPlaceholders ed escape = Maybe.mapMaybe redactGeneratedCol (getEntityFields ed) where redactGeneratedCol fd = case fieldGenerated fd of Nothing -> Just (escape (fieldDB fd), "?") Just _ -> Nothing parseExistsResult :: Maybe [PersistValue] -> Text -> String -> Bool parseExistsResult mm sql errloc = case mm of Just [PersistBool b] -> b -- Postgres Just [PersistInt64 i] -> i > 0 -- MySQL, SQLite Just [PersistDouble i] -> (truncate i :: Int64) > 0 -- gb oracle Just [PersistByteString i] -> case readInteger i of -- gb mssql Just (ret,"") -> ret > 0 xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" Just xs -> error $ errloc ++ ": Expected a boolean, int, double, or bytestring; got: " ++ show xs ++ " for query: " ++ show sql Nothing -> error $ errloc ++ ": Expected a boolean, int, double, or bytestring; got: Nothing for query: " ++ show sql persistent-2.14.6.0/Database/Persist/SqlBackend.hs0000644000000000000000000001670314476403105020043 0ustar0000000000000000-- | This module contains types and information necessary for a SQL database. -- Database support libraries, like @persistent-postgresql@, will be responsible -- for constructing these values. module Database.Persist.SqlBackend ( -- * The type and construction SqlBackend , mkSqlBackend , MkSqlBackendArgs(..) , SqlBackendHooks , emptySqlBackendHooks -- * Utilities -- $utilities -- ** SqlBackend Getters , getRDBMS , getEscapedFieldName , getEscapedRawName , getEscapeRawNameFunction , getConnLimitOffset , getConnUpsertSql , getConnVault , getConnHooks -- ** SqlBackend Setters , setConnMaxParams , setConnRepsertManySql , setConnInsertManySql , setConnUpsertSql , setConnPutManySql , setConnVault , modifyConnVault , setConnHooks -- ** SqlBackendHooks ) where import Control.Monad.Reader import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Vault.Strict (Vault) import Database.Persist.Class.PersistStore (BackendCompatible(..)) import Database.Persist.Names import Database.Persist.SqlBackend.Internal import qualified Database.Persist.SqlBackend.Internal as SqlBackend (SqlBackend(..)) import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk (MkSqlBackendArgs(..)) import Database.Persist.Types.Base -- $utilities -- -- The functions exported here are a bit more general than the record accessors. -- The easiest way to use them is to provide the 'SqlBackend' directly to the -- function. However, you can also use them in a 'ReaderT' context, and you can -- even use them with any @backend@ type tht has a @'BackendCompatible' -- 'SqlBackend' backend@ instance. -- | This function can be used directly with a 'SqlBackend' to escape -- a 'FieldNameDB'. -- -- @ -- let conn :: SqlBackend -- getEscapedFieldName (FieldNameDB "asdf") conn -- @ -- -- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like -- 'SqlPersistT': -- -- @ -- query :: SqlPersistM Text -- query = do -- field <- getEscapedFieldName (FieldNameDB "asdf") -- pure field -- @ -- -- @since 2.13.0.0 getEscapedFieldName :: (BackendCompatible SqlBackend backend, MonadReader backend m) => FieldNameDB -> m Text getEscapedFieldName fieldName = do func <- asks (SqlBackend.connEscapeFieldName . projectBackend) pure (func fieldName) -- | This function can be used directly with a 'SqlBackend' to escape -- a raw 'Text'. -- -- @ -- let conn :: SqlBackend -- getEscapedRawName (FieldNameDB "asdf") conn -- @ -- -- Alternatively, you can use it in a @'ReaderT' 'SqlBackend'@ context, like -- 'SqlPersistT': -- -- @ -- query :: SqlPersistM Text -- query = do -- field <- getEscapedRawName (FieldNameDB "asdf") -- pure field -- @ -- -- @since 2.13.0.0 getEscapedRawName :: (BackendCompatible SqlBackend backend, MonadReader backend m) => Text -> m Text getEscapedRawName name = do func <- getEscapeRawNameFunction pure (func name) -- | Return the function for escaping a raw name. -- -- @since 2.13.0.0 getEscapeRawNameFunction :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m (Text -> Text) getEscapeRawNameFunction = do asks (SqlBackend.connEscapeRawName . projectBackend) -- | Decorate the given SQL query with the @(LIMIT, OFFSET)@ specified. -- -- @since 2.13.0.0 getConnLimitOffset :: (BackendCompatible SqlBackend backend, MonadReader backend m) => (Int, Int) -- ^ The @(LIMIT, OFFSET)@ to put on the query. -> Text -- ^ The SQL query that the LIMIT/OFFSET clause will be attached to. -> m Text getConnLimitOffset limitOffset sql = do func <- asks (SqlBackend.connLimitOffset . projectBackend) pure $ func limitOffset sql -- | Retrieve the function for generating an upsert statement, if the backend -- supports it. -- -- @since 2.13.0.0 getConnUpsertSql :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m (Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text)) getConnUpsertSql = do asks (SqlBackend.connUpsertSql . projectBackend) -- | Retrieve the vault from the provided database backend. -- -- @since 2.13.3.0 getConnVault :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m Vault getConnVault = do asks (SqlBackend.connVault . projectBackend) -- | Retrieve instrumentation hooks from the provided database backend. -- -- @since 2.13.3.0 getConnHooks :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m SqlBackendHooks getConnHooks = do asks (SqlBackend.connHooks . projectBackend) -- | Get a tag displaying what database the 'SqlBackend' is for. Can be -- used to differentiate features in downstream libraries for different -- database backends. -- @since 2.13.3.0 getRDBMS :: (BackendCompatible SqlBackend backend, MonadReader backend m) => m Text getRDBMS = do asks (SqlBackend.connRDBMS . projectBackend) -- | Set the maximum parameters that may be issued in a given SQL query. This -- should be used only if the database backend have this limitation. -- -- @since 2.13.0.0 setConnMaxParams :: Int -> SqlBackend -> SqlBackend setConnMaxParams i sb = sb { connMaxParams = Just i } -- | Set the 'connRepsertManySql' field on the 'SqlBackend'. This should only be -- set by the database backend library. If this is not set, a slow default will -- be used. -- -- @since 2.13.0.0 setConnRepsertManySql :: (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend setConnRepsertManySql mkQuery sb = sb { connRepsertManySql = Just mkQuery } -- | Set the 'connInsertManySql' field on the 'SqlBackend'. This should only be -- used by the database backend library to provide an efficient implementation -- of a bulk insert function. If this is not set, a slow default will be used. -- -- @since 2.13.0.0 setConnInsertManySql :: (EntityDef -> [[PersistValue]] -> InsertSqlResult) -> SqlBackend -> SqlBackend setConnInsertManySql mkQuery sb = sb { connInsertManySql = Just mkQuery } -- | Set the 'connUpsertSql' field on the 'SqlBackend'. This should only be used -- by the database backend library to provide an efficient implementation of -- a bulk insert function. If this is not set, a slow default will be used. -- -- @since 2.13.0.0 setConnUpsertSql :: (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) -> SqlBackend -> SqlBackend setConnUpsertSql mkQuery sb = sb { connUpsertSql = Just mkQuery } -- | Set the 'connPutManySql field on the 'SqlBackend'. This should only be used -- by the database backend library to provide an efficient implementation of -- a bulk insert function. If this is not set, a slow default will be used. -- -- @since 2.13.0.0 setConnPutManySql :: (EntityDef -> Int -> Text) -> SqlBackend -> SqlBackend setConnPutManySql mkQuery sb = sb { connPutManySql = Just mkQuery } -- | Set the vault on the provided database backend. -- -- @since 2.13.0 setConnVault :: Vault -> SqlBackend -> SqlBackend setConnVault vault sb = sb { connVault = vault } -- | Modify the vault on the provided database backend. -- -- @since 2.13.0 modifyConnVault :: (Vault -> Vault) -> SqlBackend -> SqlBackend modifyConnVault f sb = sb { connVault = f $ connVault sb } -- | Set hooks on the provided database backend. -- -- @since 2.13.0 setConnHooks :: SqlBackendHooks -> SqlBackend -> SqlBackend setConnHooks hooks sb = sb { connHooks = hooks } persistent-2.14.6.0/Database/Persist/SqlBackend/StatementCache.hs0000644000000000000000000000451414476403105022730 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Database.Persist.SqlBackend.StatementCache ( StatementCache , StatementCacheKey , mkCacheKeyFromQuery , MkStatementCache(..) , mkSimpleStatementCache , mkStatementCache ) where import Data.Foldable import Data.IORef import qualified Data.Map as Map 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 -- -- @since 2.13.3 data MkStatementCache = MkStatementCache { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) -- ^ Retrieve a statement from the cache, or return nothing if it is not found. -- -- @since 2.13.3 , statementCacheInsert :: StatementCacheKey -> Statement -> IO () -- ^ Put a new statement into the cache. An immediate lookup of -- the statement MUST return the inserted statement for the given -- cache key. Depending on the implementation, the statement cache MAY -- choose to evict other statements from the cache within this function. -- -- @since 2.13.3 , statementCacheClear :: IO () -- ^ Remove all statements from the cache. Implementations of this -- should be sure to call `stmtFinalize` on all statements removed -- from the cache. -- -- @since 2.13.3 , statementCacheSize :: IO Int -- ^ Get the current size of the cache. -- -- @since 2.13.3 } -- | Make a simple statement cache that will cache statements if they are not currently cached. -- -- @since 2.13.3 mkSimpleStatementCache :: IORef (Map Text Statement) -> MkStatementCache mkSimpleStatementCache stmtMap = MkStatementCache { statementCacheLookup = \sql -> Map.lookup (cacheKey sql) <$> readIORef stmtMap , statementCacheInsert = \sql stmt -> modifyIORef' stmtMap (Map.insert (cacheKey sql) stmt) , statementCacheClear = do oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) traverse_ stmtFinalize oldStatements , statementCacheSize = Map.size <$> readIORef stmtMap } -- | Create a statement cache. -- -- @since 2.13.0 mkStatementCache :: MkStatementCache -> StatementCache mkStatementCache MkStatementCache{..} = StatementCache { .. } persistent-2.14.6.0/Database/Persist/SqlBackend/SqlPoolHooks.hs0000644000000000000000000000713314476403105022435 0ustar0000000000000000module Database.Persist.SqlBackend.SqlPoolHooks ( SqlPoolHooks , defaultSqlPoolHooks , getAlterBackend , modifyAlterBackend , setAlterBackend , getRunBefore , modifyRunBefore , setRunBefore , getRunAfter , modifyRunAfter , setRunAfter , getRunOnException ) where import Control.Exception import Control.Monad.IO.Class import Database.Persist.Sql.Raw import Database.Persist.SqlBackend.Internal import Database.Persist.SqlBackend.Internal.SqlPoolHooks import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.Class.PersistStore -- | Lifecycle hooks that may be altered to extend SQL pool behavior -- in a backwards compatible fashion. -- -- By default, the hooks have the following semantics: -- -- - 'alterBackend' has no effect -- - 'runBefore' begins a transaction -- - 'runAfter' commits the current transaction -- - 'runOnException' rolls back the current transaction -- -- @since 2.13.3.0 defaultSqlPoolHooks :: (MonadIO m, BackendCompatible SqlBackend backend) => SqlPoolHooks m backend defaultSqlPoolHooks = SqlPoolHooks { alterBackend = pure , runBefore = \conn mi -> do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend liftIO $ connBegin sqlBackend getter mi , runAfter = \conn _ -> do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend liftIO $ connCommit sqlBackend getter , runOnException = \conn _ _ -> do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend liftIO $ connRollback sqlBackend getter } getAlterBackend :: SqlPoolHooks m backend -> (backend -> m backend) getAlterBackend = alterBackend modifyAlterBackend :: SqlPoolHooks m backend -> ((backend -> m backend) -> (backend -> m backend)) -> SqlPoolHooks m backend modifyAlterBackend hooks f = hooks { alterBackend = f $ alterBackend hooks } setAlterBackend :: SqlPoolHooks m backend -> (backend -> m backend) -> SqlPoolHooks m backend setAlterBackend hooks f = hooks { alterBackend = f } getRunBefore :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) getRunBefore = runBefore modifyRunBefore :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> m ()) -> (backend -> Maybe IsolationLevel -> m ())) -> SqlPoolHooks m backend modifyRunBefore hooks f = hooks { runBefore = f $ runBefore hooks } setRunBefore :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) -> SqlPoolHooks m backend setRunBefore h f = h { runBefore = f } getRunAfter :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) getRunAfter = runAfter modifyRunAfter :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> m ()) -> (backend -> Maybe IsolationLevel -> m ())) -> SqlPoolHooks m backend modifyRunAfter hooks f = hooks { runAfter = f $ runAfter hooks } setRunAfter :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) -> SqlPoolHooks m backend setRunAfter hooks f = hooks { runAfter = f } getRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) getRunOnException = runOnException modifyRunOnException :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> SomeException -> m ()) -> (backend -> Maybe IsolationLevel -> SomeException -> m ())) -> SqlPoolHooks m backend modifyRunOnException hooks f = hooks { runOnException = f $ runOnException hooks } setRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) -> SqlPoolHooks m backend setRunOnException hooks f = hooks { runOnException = f } persistent-2.14.6.0/Database/Persist/SqlBackend/Internal.hs0000644000000000000000000001657214476403105021623 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Database.Persist.SqlBackend.Internal where import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Vault.Strict (Vault) import qualified Data.Vault.Strict as Vault import Database.Persist.Class.PersistStore import Database.Persist.Names import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.SqlBackend.Internal.MkSqlBackend import Database.Persist.SqlBackend.Internal.Statement import Database.Persist.SqlBackend.StatementCache import Database.Persist.Types.Base -- | A 'SqlBackend' represents a handle or connection to a database. It -- contains functions and values that allow databases to have more -- optimized implementations, as well as references that benefit -- performance and sharing. -- -- Instead of using the 'SqlBackend' constructor directly, use the -- 'mkSqlBackend' function. -- -- A 'SqlBackend' is *not* thread-safe. You should not assume that -- a 'SqlBackend' can be shared among threads and run concurrent queries. -- This *will* result in problems. Instead, you should create a @'Pool' -- 'SqlBackend'@, known as a 'ConnectionPool', and pass that around in -- multi-threaded applications. -- -- To run actions in the @persistent@ library, you should use the -- 'runSqlConn' function. If you're using a multithreaded application, use -- the 'runSqlPool' function. data SqlBackend = SqlBackend { connPrepare :: Text -> IO Statement -- ^ This function should prepare a 'Statement' in the target database, -- which should allow for efficient query reuse. , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult -- ^ This function generates the SQL and values necessary for -- performing an insert against the database. , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) -- ^ SQL for inserting many rows and returning their primary keys, for -- backends that support this functionality. If 'Nothing', rows will be -- inserted one-at-a-time using 'connInsertSql'. , connUpsertSql :: Maybe (EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text) -- ^ Some databases support performing UPSERT _and_ RETURN entity -- in a single call. -- -- This field when set will be used to generate the UPSERT+RETURN sql given -- * an entity definition -- * updates to be run on unique key(s) collision -- -- When left as 'Nothing', we find the unique key from entity def before -- * trying to fetch an entity by said key -- * perform an update when result found, else issue an insert -- * return new entity from db -- -- @since 2.6 , connPutManySql :: Maybe (EntityDef -> Int -> Text) -- ^ Some databases support performing bulk UPSERT, specifically -- "insert or replace many records" in a single call. -- -- This field when set, given -- * an entity definition -- * number of records to be inserted -- should produce a PUT MANY sql with placeholders for records -- -- When left as 'Nothing', we default to using 'defaultPutMany'. -- -- @since 2.8.1 , connStmtMap :: StatementCache -- ^ A reference to the cache of statements. 'Statement's are keyed by -- the 'Text' queries that generated them. , connClose :: IO () -- ^ Close the underlying connection. , connMigrateSql :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) -- ^ This function returns the migrations required to include the -- 'EntityDef' parameter in the @['EntityDef']@ database. This might -- include creating a new table if the entity is not present, or -- altering an existing table if it is. , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () -- ^ A function to begin a transaction for the underlying database. , connCommit :: (Text -> IO Statement) -> IO () -- ^ A function to commit a transaction to the underlying database. , connRollback :: (Text -> IO Statement) -> IO () -- ^ A function to roll back a transaction on the underlying database. , connEscapeFieldName :: FieldNameDB -> Text -- ^ A function to extract and escape the name of the column corresponding -- to the provided field. -- -- @since 2.12.0.0 , connEscapeTableName :: EntityDef -> Text -- ^ A function to extract and escape the name of the table corresponding -- to the provided entity. PostgreSQL uses this to support schemas. -- -- @since 2.12.0.0 , connEscapeRawName :: Text -> Text -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while -- PostgreSQL uses quotes, and so on. -- -- @since 2.12.0.0 , connNoLimit :: Text , connRDBMS :: Text -- ^ A tag displaying what database the 'SqlBackend' is for. Can be -- used to differentiate features in downstream libraries for different -- database backends. , connLimitOffset :: (Int,Int) -> Text -> Text -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that -- LIMIT/OFFSET is problematic for performance, and indexed range -- queries are the superior way to offer pagination. , connLogFunc :: LogFunc -- ^ A log function for the 'SqlBackend' to use. , connMaxParams :: Maybe Int -- ^ Some databases (probably only Sqlite) have a limit on how -- many question-mark parameters may be used in a statement -- -- @since 2.6.1 , connRepsertManySql :: Maybe (EntityDef -> Int -> Text) -- ^ Some databases support performing bulk an atomic+bulk INSERT where -- constraint conflicting entities can replace existing entities. -- -- This field when set, given -- * an entity definition -- * number of records to be inserted -- should produce a INSERT sql with placeholders for primary+record fields -- -- When left as 'Nothing', we default to using 'defaultRepsertMany'. -- -- @since 2.9.0 , connVault :: Vault -- ^ Carry arbitrary payloads for the connection that -- may be used to propagate information into hooks. , connHooks :: SqlBackendHooks -- ^ Instrumentation hooks that may be used to track the -- behaviour of a backend. } newtype SqlBackendHooks = SqlBackendHooks { hookGetStatement :: SqlBackend -> Text -> Statement -> IO Statement } emptySqlBackendHooks :: SqlBackendHooks emptySqlBackendHooks = SqlBackendHooks { hookGetStatement = \_ _ s -> pure s } -- | A function for creating a value of the 'SqlBackend' type. You should prefer -- to use this instead of the constructor for 'SqlBackend', because default -- values for this will be provided for new fields on the record when new -- functionality is added. -- -- @since 2.13.0.0 mkSqlBackend :: MkSqlBackendArgs -> SqlBackend mkSqlBackend MkSqlBackendArgs {..} = SqlBackend { connMaxParams = Nothing , connRepsertManySql = Nothing , connPutManySql = Nothing , connUpsertSql = Nothing , connInsertManySql = Nothing , connVault = Vault.empty , connHooks = emptySqlBackendHooks , connStmtMap = mkStatementCache $ mkSimpleStatementCache connStmtMap , .. } instance HasPersistBackend SqlBackend where type BaseBackend SqlBackend = SqlBackend persistBackend = id instance IsPersistBackend SqlBackend where mkPersistBackend = id persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/InsertSqlResult.hs0000644000000000000000000000037314476403105024736 0ustar0000000000000000module Database.Persist.SqlBackend.Internal.InsertSqlResult where import Database.Persist.Types.Base (PersistValue) import Data.Text (Text) data InsertSqlResult = ISRSingle Text | ISRInsertGet Text Text | ISRManyKeys Text [PersistValue] persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/IsolationLevel.hs0000644000000000000000000000137014476403105024542 0ustar0000000000000000module Database.Persist.SqlBackend.Internal.IsolationLevel where import Data.String (IsString(..)) -- | Please refer to the documentation for the database in question for a full -- overview of the semantics of the varying isloation levels data IsolationLevel = ReadUncommitted | ReadCommitted | RepeatableRead | Serializable deriving (Show, Eq, Enum, Ord, Bounded) makeIsolationLevelStatement :: (Monoid s, IsString s) => IsolationLevel -> s makeIsolationLevelStatement l = "SET TRANSACTION ISOLATION LEVEL " <> case l of ReadUncommitted -> "READ UNCOMMITTED" ReadCommitted -> "READ COMMITTED" RepeatableRead -> "REPEATABLE READ" Serializable -> "SERIALIZABLE" persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs0000644000000000000000000000174614476403105024215 0ustar0000000000000000module Database.Persist.SqlBackend.Internal.SqlPoolHooks ( SqlPoolHooks(..) ) where import Control.Exception (SomeException) import Database.Persist.SqlBackend.Internal.IsolationLevel -- | A set of hooks that may be used to alter the behaviour -- of @runSqlPoolWithExtensibleHooks@ in a backwards-compatible -- fashion. data SqlPoolHooks m backend = SqlPoolHooks { alterBackend :: backend -> m backend -- ^ Alter the backend prior to executing any actions with it. , runBefore :: backend -> Maybe IsolationLevel -> m () -- ^ Run this action immediately before the action is performed. , runAfter :: backend -> Maybe IsolationLevel -> m () -- ^ Run this action immediately after the action is completed. , runOnException :: backend -> Maybe IsolationLevel -> SomeException -> m () -- ^ This action is performed when an exception is received. The -- exception is provided as a convenience - it is rethrown once this -- cleanup function is complete. } persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/Statement.hs0000644000000000000000000000106114476403105023552 0ustar0000000000000000{-# language RankNTypes #-} module Database.Persist.SqlBackend.Internal.Statement where import Data.Acquire import Database.Persist.Types.Base import Data.Int import Conduit -- | A 'Statement' is a representation of a database query that has been -- prepared and stored on the server side. data Statement = Statement { stmtFinalize :: IO () , stmtReset :: IO () , stmtExecute :: [PersistValue] -> IO Int64 , stmtQuery :: forall m. MonadIO m => [PersistValue] -> Acquire (ConduitM () [PersistValue] m ()) } persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/StatementCache.hs0000644000000000000000000000150514476403105024501 0ustar0000000000000000module Database.Persist.SqlBackend.Internal.StatementCache where import Data.Text (Text) import Database.Persist.SqlBackend.Internal.Statement -- | A statement cache used to lookup statements that have already been prepared -- for a given query. -- -- @since 2.13.3 data StatementCache = StatementCache { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) , statementCacheInsert :: StatementCacheKey -> Statement -> IO () , statementCacheClear :: IO () , statementCacheSize :: IO Int } newtype StatementCacheKey = StatementCacheKey { cacheKey :: Text } -- Wrapping around this to allow for more efficient keying mechanisms -- in the future, perhaps. -- | Construct a `StatementCacheKey` from a raw SQL query. mkCacheKeyFromQuery :: Text -> StatementCacheKey mkCacheKeyFromQuery = StatementCacheKey persistent-2.14.6.0/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs0000644000000000000000000000674614476403105024124 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Database.Persist.SqlBackend.Internal.MkSqlBackend where import Control.Monad.Logger (Loc, LogLevel, LogSource, LogStr) 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 -- 'SqlBackend' constructor directly to the 'mkSqlBackend' function. -- -- This type will only contain required fields for constructing a 'SqlBackend'. -- For fields that aren't present on this record, you'll want to use the various -- @set@ functions or -- -- @since 2.13.0.0 data MkSqlBackendArgs = MkSqlBackendArgs { connPrepare :: Text -> IO Statement -- ^ This function should prepare a 'Statement' in the target database, -- which should allow for efficient query reuse. , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult -- ^ This function generates the SQL and values necessary for -- performing an insert against the database. , connStmtMap :: IORef (Map Text Statement) -- ^ A reference to the cache of statements. 'Statement's are keyed by -- the 'Text' queries that generated them. , connClose :: IO () -- ^ Close the underlying connection. , connMigrateSql :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) -- ^ This function returns the migrations required to include the -- 'EntityDef' parameter in the @['EntityDef']@ database. This might -- include creating a new table if the entity is not present, or -- altering an existing table if it is. , connBegin :: (Text -> IO Statement) -> Maybe IsolationLevel -> IO () -- ^ A function to begin a transaction for the underlying database. , connCommit :: (Text -> IO Statement) -> IO () -- ^ A function to commit a transaction to the underlying database. , connRollback :: (Text -> IO Statement) -> IO () -- ^ A function to roll back a transaction on the underlying database. , connEscapeFieldName :: FieldNameDB -> Text -- ^ A function to extract and escape the name of the column corresponding -- to the provided field. -- -- @since 2.12.0.0 , connEscapeTableName :: EntityDef -> Text -- ^ A function to extract and escape the name of the table corresponding -- to the provided entity. PostgreSQL uses this to support schemas. -- -- @since 2.12.0.0 , connEscapeRawName :: Text -> Text -- ^ A function to escape raw DB identifiers. MySQL uses backticks, while -- PostgreSQL uses quotes, and so on. -- -- @since 2.12.0.0 , connNoLimit :: Text , connRDBMS :: Text -- ^ A tag displaying what database the 'SqlBackend' is for. Can be -- used to differentiate features in downstream libraries for different -- database backends. , connLimitOffset :: (Int,Int) -> Text -> Text -- ^ Attach a 'LIMIT/OFFSET' clause to a SQL query. Note that -- LIMIT/OFFSET is problematic for performance, and indexed range -- queries are the superior way to offer pagination. , connLogFunc :: LogFunc -- ^ A log function for the 'SqlBackend' to use. } type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () persistent-2.14.6.0/Database/Persist/Class.hs0000644000000000000000000001300514476403105017071 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} -- | This module exports all of the type classes in @persistent@ for operating -- on the database backends. -- -- @persistent@ offers methods that are abstract in the specific @backend@ type. -- For SQL databases, this wil be 'Database.Persist.SqlBackend.SqlBackend'. -- Other database backends will define their own types. -- -- Methods and functions in this module have examples documented under an -- "Example Usage" thing, that you need to click on to expand. -- module Database.Persist.Class ( -- * PersistStore -- | The 'PersistStore', 'PersistStoreRead', and 'PersistStoreWrite' type -- classes are used to define basic operations on the database. A database -- that implements these classes is capable of being used as a simple -- key-value store. -- -- All the examples present here will be explained based on these schemas, datasets and functions: -- -- = schema-1 -- -- #schema-persist-store-1# -- -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > User -- > name String -- > age Int -- > deriving Show -- > |] -- -- = dataset-1 -- -- #dataset-persist-store-1# -- -- > +----+-------+-----+ -- > | id | name | age | -- > +----+-------+-----+ -- > | 1 | SPJ | 40 | -- > +----+-------+-----+ -- > | 2 | Simon | 41 | -- > +----+-------+-----+ PersistStore , PersistStoreRead (..) , PersistStoreWrite (..) , PersistRecordBackend , getJust , getJustEntity , getEntity , belongsTo , belongsToJust , SafeToInsert , 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 , PersistUniqueRead (..) , PersistUniqueWrite (..) , OnlyOneUniqueKey (..) , AtLeastOneUniqueKey (..) , onlyOneUniqueDef , NoUniqueKeysError , MultipleUniqueKeysError , getByValue , insertBy , insertUniqueEntity , replaceUnique , checkUnique , 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. , selectList , selectKeys , PersistQuery , PersistQueryRead (..) , PersistQueryWrite (..) , selectSource , selectKeysList -- * PersistEntity , PersistEntity (..) , tabulateEntity , SymbolToField (..) -- * PersistField , PersistField (..) -- * PersistConfig , PersistConfig (..) , entityValues -- * Lifting , HasPersistBackend (..) , withBaseBackend , IsPersistBackend () , liftPersist , 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 (..) , ToBackendKey (..) -- * JSON utilities , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON , toPersistValueJSON, fromPersistValueJSON ) where import Database.Persist.Class.PersistConfig import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistUnique -- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. -- It signifies the assumption that, by default, a backend can write as well as read. type PersistUnique a = PersistUniqueWrite a -- | 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. type PersistQuery a = PersistQueryWrite a -- | 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. type PersistStore a = PersistStoreWrite a persistent-2.14.6.0/Database/Persist/Class/PersistEntity.hs0000644000000000000000000005362214507117603021730 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# language PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..) , tabulateEntity , Update (..) , BackendSpecificUpdate , SelectOpt (..) , Filter (..) , FilterValue (..) , BackendSpecificFilter , Entity (.., Entity, entityKey, entityVal) , ViaPersistEntity (..) , recordName , entityValues , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON -- * PersistField based on other typeclasses , toPersistValueJSON, fromPersistValueJSON , toPersistValueEnum, fromPersistValueEnum -- * Support for @OverloadedLabels@ with 'EntityField' , SymbolToField (..) , -- * Safety check for inserts SafeToInsert , SafeToInsertErrorMessage ) where import Data.Functor.Constant import Data.Aeson ( 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.Attoparsec.ByteString (parseOnly) import Data.Functor.Identity import Web.PathPieces (PathMultiPiece(..), PathPiece(..)) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as AM #else import qualified Data.HashMap.Strict as AM #endif import GHC.Records import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isJust) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB import GHC.Generics import GHC.OverloadedLabels import GHC.TypeLits import Data.Kind (Type) import Database.Persist.Class.PersistField import Database.Persist.Names import Database.Persist.Types.Base -- | Persistent serialized Haskell records to the database. -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc) -- corresponds to a 'Key' plus a Haskell record. -- -- For every Haskell record type stored in the database there is a -- corresponding 'PersistEntity' instance. An instance of PersistEntity -- contains meta-data for the record. PersistEntity also helps abstract -- over different record types. That way the same query interface can return -- a 'PersistEntity', with each query returning different types of Haskell -- records. -- -- 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 -- | Persistent allows multiple different backends (databases). type PersistEntityBackend record -- | By default, a backend will automatically generate the key -- Instead you can specify a Primary key made up of unique values. data Key record -- | A lower-level key operation. keyToValues :: Key record -> [PersistValue] -- | A lower-level key operation. keyFromValues :: [PersistValue] -> Either Text (Key record) -- | A meta-operation to retrieve the 'Key' 'EntityField'. persistIdField :: EntityField record (Key record) -- | Retrieve the 'EntityDef' meta-data for the record. entityDef :: proxy record -> EntityDef -- | An 'EntityField' is parameterised by the Haskell record it belongs to -- and the additional type of that field. -- -- As of @persistent-2.11.0.0@, it's possible to use the @OverloadedLabels@ -- language extension to refer to 'EntityField' values polymorphically. See -- the documentation on 'SymbolToField' for more information. data EntityField record :: Type -> Type -- | Return meta-data for a given 'EntityField'. persistFieldDef :: EntityField record typ -> FieldDef -- | A meta-operation to get the database fields of a record. toPersistFields :: record -> [PersistValue] -- | A lower-level operation to convert from database values to a Haskell record. fromPersistValues :: [PersistValue] -> Either Text record -- | This function allows you to build an @'Entity' a@ by specifying an -- action that returns a value for the field in the callback function. -- Let's look at an example. -- -- @ -- parseFromEnvironmentVariables :: IO (Entity User) -- parseFromEnvironmentVariables = -- tabulateEntityA $ \\userField -> -- case userField of -- UserName -> -- getEnv "USER_NAME" -- UserAge -> do -- ageVar <- getEnv "USER_AGE" -- case readMaybe ageVar of -- Just age -> -- pure age -- Nothing -> -- error $ "Failed to parse Age from: " <> ageVar -- UserAddressId -> do -- addressVar <- getEnv "USER_ADDRESS_ID" -- pure $ AddressKey addressVar -- @ -- -- @since 2.14.0.0 tabulateEntityA :: Applicative f => (forall a. EntityField record a -> f a) -- ^ A function that builds a fragment of a record in an -- 'Applicative' context. -> f (Entity record) -- | 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) -- | 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)) -- | Extract a @'Key' record@ from a @record@ value. Currently, this is -- only defined for entities using the @Primary@ syntax for -- natural/composite keys. In a future version of @persistent@ which -- incorporates the ID directly into the entity, this will always be Just. -- -- @since 2.11.0.0 keyFromRecordM :: Maybe (record -> Key record) keyFromRecordM = Nothing -- | Newtype wrapper for optionally deriving typeclass instances on -- 'PersistEntity' keys. -- -- @since 2.14.6.0 newtype ViaPersistEntity record = ViaPersistEntity (Key record) instance PersistEntity record => PathMultiPiece (ViaPersistEntity record) where fromPathMultiPiece pieces = do Right key <- keyFromValues <$> mapM fromPathPiece pieces pure $ ViaPersistEntity key toPathMultiPiece (ViaPersistEntity key) = map toPathPiece $ keyToValues key -- | Construct an @'Entity' record@ by providing a value for each of the -- record's fields. -- -- These constructions are equivalent: -- -- @ -- entityMattConstructor, entityMattTabulate :: Entity User -- entityMattConstructor = -- Entity -- { entityKey = toSqlKey 123 -- , entityVal = -- User -- { userName = "Matt" -- , userAge = 33 -- } -- } -- -- entityMattTabulate = -- tabulateEntity $ \\case -- UserId -> -- toSqlKey 123 -- UserName -> -- "Matt" -- UserAge -> -- 33 -- @ -- -- This is a specialization of 'tabulateEntityA', which allows you to -- construct an 'Entity' by providing an 'Applicative' action for each -- field instead of a regular function. -- -- @since 2.14.0.0 tabulateEntity :: PersistEntity record => (forall a. EntityField record a -> a) -> Entity record tabulateEntity fromField = runIdentity (tabulateEntityA (Identity . fromField)) type family BackendSpecificUpdate backend record -- Moved over from Database.Persist.Class.PersistUnique -- | Textual representation of the record recordName :: (PersistEntity record) => record -> Text recordName = unEntityNameHS . entityHaskell . entityDef . Just -- | Updating a database entity. -- -- Persistent users use combinators to create these. data Update record = forall typ. PersistField typ => Update { updateField :: EntityField record typ , updateValue :: typ -- FIXME Replace with expr down the road , updateUpdate :: PersistUpdate } | BackendUpdate (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 type family BackendSpecificFilter backend record -- | Filters which are available for 'select', 'updateWhere' and -- 'deleteWhere'. Each filter constructor specifies the field being -- filtered on, the type of comparison applied (equals, not equals, etc) -- and the argument for the comparison. -- -- Persistent users use combinators to create these. -- -- Note that it's important to be careful about the 'PersistFilter' that -- you are using, if you use this directly. For example, using the 'In' -- '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] | BackendFilter (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 -- | Datatype that represents an entity, with both its 'Key' and -- its Haskell record representation. -- -- When using a SQL-based backend (such as SQLite or -- PostgreSQL), an 'Entity' may take any number of columns -- depending on how many fields it has. In order to reconstruct -- your entity on the Haskell side, @persistent@ needs all of -- your entity columns and in the right order. Note that you -- don't need to worry about this when using @persistent@\'s API -- since everything is handled correctly behind the scenes. -- -- However, if you want to issue a raw SQL command that returns -- an 'Entity', then you have to be careful with the column -- order. While you could use @SELECT Entity.* WHERE ...@ and -- that would work most of the time, there are times when the -- order of the columns on your database is different from the -- order that @persistent@ expects (for example, if you add a new -- field in the middle of you entity definition and then use the -- migration code -- @persistent@ will expect the column to be in -- the middle, but your DBMS will put it as the last column). -- So, instead of using a query like the one above, you may use -- 'Database.Persist.Sql.rawSql' (from the -- "Database.Persist.Sql" module) with its /entity -- selection placeholder/ (a double question mark @??@). Using -- @rawSql@ the query above must be written as @SELECT ?? WHERE -- ..@. Then @rawSql@ will replace @??@ with the list of all -- columns that we need from your entity in the right order. If -- your query returns two entities (i.e. @(Entity backend a, -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on. data Entity record = Entity { entityKey :: Key record , entityVal :: record } deriving 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 (Entity k 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 -- | Predefined @toJSON@. The resulting JSON looks like -- @{"key": 1, "value": {"name": ...}}@. -- -- The typical usage is: -- -- @ -- instance ToJSON (Entity User) where -- toJSON = keyValueEntityToJSON -- @ 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": ...}}@. -- -- The typical usage is: -- -- @ -- 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 _ = fail "keyValueEntityFromJSON: not an object" -- | Predefined @toJSON@. The resulting JSON looks like -- @{"id": 1, "name": ...}@. -- -- The typical usage is: -- -- @ -- instance ToJSON (Entity User) where -- toJSON = entityIdToJSON -- @ 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 -- | Predefined @parseJSON@. The input JSON looks like -- @{"id": 1, "name": ...}@. -- -- The typical usage is: -- -- @ -- instance FromJSON (Entity User) where -- parseJSON = entityIdFromJSON -- @ entityIdFromJSON :: (PersistEntity record, FromJSON record) => Value -> Parser (Entity record) entityIdFromJSON = withObject "entityIdFromJSON" $ \o -> do val <- parseJSON (Object o) k <- case keyFromRecordM of Nothing -> o .: "id" Just func -> pure $ func val pure $ Entity k val instance (PersistEntity record, PersistField record, PersistField (Key record)) => PersistField (Entity record) where 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 -> 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) errMsg :: Text -> Text errMsg = mappend "PersistField entity fromPersistValue: " -- | Realistically this is only going to be used for MongoDB, -- so lets use MongoDB conventions idField :: Text idField = "_id" -- | Convenience function for getting a free 'PersistField' instance -- from a type with JSON instances. -- -- -- Example usage in combination with 'fromPersistValueJSON': -- -- @ -- instance PersistField MyData where -- fromPersistValue = fromPersistValueJSON -- toPersistValue = toPersistValueJSON -- @ toPersistValueJSON :: ToJSON a => a -> PersistValue toPersistValueJSON = PersistText . LT.toStrict . TB.toLazyText . encodeToTextBuilder . toJSON -- | Convenience function for getting a free 'PersistField' instance -- from a type with JSON instances. The JSON parser used will accept JSON -- values other that object and arrays. So, if your instance serializes the -- data to a JSON string, this will still work. -- -- -- Example usage in combination with 'toPersistValueJSON': -- -- @ -- instance PersistField MyData where -- fromPersistValue = fromPersistValueJSON -- toPersistValue = toPersistValueJSON -- @ 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 Error err -> Left err Success a -> Right a 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' -- from the persistent-template package should generally be preferred. -- However, if you want to ensure that an @ORDER BY@ clause that uses -- your field will order rows by the data constructor order, this is -- a better choice. -- -- Example usage in combination with 'fromPersistValueEnum': -- -- @ -- data SeverityLevel = Low | Medium | Critical | High -- deriving (Enum, Bounded) -- instance PersistField SeverityLevel where -- fromPersistValue = fromPersistValueEnum -- toPersistValue = toPersistValueEnum -- @ toPersistValueEnum :: Enum a => a -> PersistValue toPersistValueEnum = toPersistValue . fromEnum -- | Convenience function for getting a free 'PersistField' instance -- from a type with an 'Enum' instance. This function also requires -- a `Bounded` instance to improve the reporting of errors. -- -- Example usage in combination with 'toPersistValueEnum': -- -- @ -- data SeverityLevel = Low | Medium | Critical | High -- deriving (Enum, Bounded) -- instance PersistField SeverityLevel where -- fromPersistValue = fromPersistValueEnum -- toPersistValue = toPersistValueEnum -- @ 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") -- | This type class is used with the @OverloadedLabels@ extension to -- provide a more convenient means of using the 'EntityField' type. -- 'EntityField' definitions are prefixed with the type name to avoid -- ambiguity, but this ambiguity can result in verbose code. -- -- If you have a table @User@ with a @name Text@ field, then the -- corresponding 'EntityField' is @UserName@. With this, we can write -- @#name :: 'EntityField' User Text@. -- -- What's more fun is that the type is more general: it's actually -- @ -- #name -- :: ('SymbolToField' "name" rec typ) -- => EntityField rec typ -- @ -- -- Which means it is *polymorphic* over the actual record. This allows you -- to write code that can be generic over the tables, provided they have -- the right fields. -- -- @since 2.11.0.0 class SymbolToField (sym :: Symbol) rec typ | sym rec -> typ where symbolToField :: EntityField rec typ -- | This instance delegates to 'SymbolToField' to provide -- @OverloadedLabels@ support to the 'EntityField' type. -- -- @since 2.11.0.0 instance SymbolToField sym rec typ => IsLabel sym (EntityField rec typ) where fromLabel = symbolToField @sym -- | A type class which is used to witness that a type is safe to insert into -- the database without providing a primary key. -- -- The @TemplateHaskell@ function 'mkPersist' will generate instances of this -- class for any entity that it works on. If the entity has a default primary -- key, then it provides a regular instance. If the entity has a @Primary@ -- natural key, then this works fine. But if the entity has an @Id@ column with -- no @default=@, then this does a 'TypeError' and forces the user to use -- 'insertKey'. -- -- @since 2.14.0.0 class SafeToInsert a where type SafeToInsertErrorMessage a = 'Text "The PersistEntity " ':<>: ShowType a ':<>: 'Text " does not have a default primary key." ':$$: 'Text "This means that 'insert' will fail with a database error." ':$$: 'Text "Please provide a default= clause inthe entity definition," ':$$: 'Text "or use 'insertKey' instead to provide one." instance (TypeError (FunctionErrorMessage a b)) => SafeToInsert (a -> b) type FunctionErrorMessage a b = 'Text "Uh oh! It looks like you are trying to insert a function into the database." ':$$: 'Text "Argument: " ':<>: 'ShowType a ':$$: 'Text "Result: " ':<>: 'ShowType b ':$$: 'Text "You probably need to add more arguments to an Entity construction." type EntityErrorMessage a = 'Text "It looks like you're trying to `insert` an `Entity " ':<>: 'ShowType a ':<>: 'Text "` directly." ':$$: 'Text "You want `insertKey` instead. As an example:" ':$$: 'Text " insertKey (entityKey ent) (entityVal ent)" instance TypeError (EntityErrorMessage a) => SafeToInsert (Entity a) persistent-2.14.6.0/Database/Persist/Class/PersistQuery.hs0000644000000000000000000001634514476403105021562 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} module Database.Persist.Class.PersistQuery ( selectList , PersistQueryRead (..) , PersistQueryWrite (..) , selectSource , selectKeys , selectKeysList ) where import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, MonadReader) import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, with) import Data.Conduit (ConduitM, (.|), await, runConduit) import qualified Data.Conduit.List as CL import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity -- | Backends supporting conditional read operations. class (PersistCore backend, PersistStoreRead backend) => PersistQueryRead backend where -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. -- -- NOTE: This function returns an 'Acquire' and a 'ConduitM', which implies -- that it streams from the database. It does not. Please use 'selectList' -- to simplify the code. If you want streaming behavior, consider -- @persistent-pagination@ which efficiently chunks a query into ranges, or -- investigate a backend-specific streaming solution. selectSourceRes :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2) => [Filter record] -> [SelectOpt record] -> ReaderT backend m1 (Acquire (ConduitM () (Entity record) m2 ())) -- | 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 filts opts = do srcRes <- selectSourceRes filts (LimitTo 1 : opts) liftIO $ with srcRes (\src -> runConduit $ src .| await) -- | Get the 'Key's of all records matching the given criterion. selectKeysRes :: (MonadIO m1, MonadIO m2, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> 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 -- | Check if there is at least one record fulfilling the given criterion. -- -- @since 2.11 exists :: (MonadIO m, PersistRecordBackend record backend) => [Filter record] -> ReaderT backend m Bool -- | Backends supporting conditional write operations class (PersistQueryRead backend, PersistStoreWrite backend) => PersistQueryWrite backend where -- | Update individual fields on any record matching the given criterion. 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 () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. -- -- WARNING: This function returns a 'ConduitM', which suggests that it streams -- the results. It does not stream results on most backends. If you need -- streaming, see @persistent-pagination@ for a means of chunking results based -- on indexed ranges. selectSource :: 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 src release releaseKey -- | 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 filts opts = do srcRes <- liftPersist $ selectKeysRes filts opts (releaseKey, src) <- allocateAcquire srcRes src release releaseKey -- | Returns a @['Entity' record]@ corresponding to the filters and options -- provided. -- -- Filters are constructed using the operators defined in "Database.Persist" -- (and re-exported from "Database.Persist.Sql"). Let's look at some examples: -- -- @ -- usersWithAgeOver40 :: 'SqlPersistT' 'IO' ['Entity' User] -- usersWithAgeOver40 = -- 'selectList' [UserAge 'Database.Persist.>=.' 40] [] -- @ -- -- If you provide multiple values in the list, the conditions are @AND@ed -- together. -- -- @ -- usersWithAgeBetween30And50 :: 'SqlPersistT' 'IO' ['Entity' User] -- usersWithAgeBetween30And50 = -- 'selectList' -- [ UserAge 'Database.Persist.>=.' 30 -- , UserAge 'Database.Persist.<=.' 50 -- ] -- [] -- @ -- -- The second list contains the 'SelectOpt' for a record. We can select the -- first ten records with 'LimitTo' -- -- @ -- firstTenUsers = -- 'selectList' [] ['LimitTo' 10] -- @ -- -- And we can select the second ten users with 'OffsetBy'. -- -- @ -- secondTenUsers = -- 'selectList' [] ['LimitTo' 10, 'OffsetBy' 10] -- @ -- -- -- -- The type of record can usually be infered from the types of the provided filters -- and select options. In the previous two examples, though, you'll notice that the -- select options are polymorphic, applying to any record type. In order to help -- type inference in such situations, or simply as an enhancement to readability, -- you might find type application useful, illustrated below. -- -- @ -- {-# LANGUAGE TypeApplications #-} -- ... -- -- firstTenUsers = -- 'selectList' @User [] ['LimitTo' 10] -- -- secondTenUsers = -- 'selectList' @User [] ['LimitTo' 10, 'OffsetBy' 10] -- @ -- -- With 'Asc' and 'Desc', we can provide the field we want to sort on. We can -- provide multiple sort orders - later ones are used to sort records that are -- equal on the first field. -- -- @ -- newestUsers = -- selectList [] ['Desc' UserCreatedAt, 'LimitTo' 10] -- -- oldestUsers = -- selectList [] ['Asc' UserCreatedAt, 'LimitTo' 10] -- @ selectList :: forall record backend m. (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> ReaderT backend m [Entity record] selectList filts opts = do srcRes <- selectSourceRes filts opts liftIO $ with srcRes (\src -> runConduit $ src .| CL.consume) -- | Call 'selectKeys' but return the result as a list. selectKeysList :: 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) persistent-2.14.6.0/Database/Persist/Class/PersistUnique.hs0000644000000000000000000006633114507117603021723 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique ( PersistUniqueRead(..) , PersistUniqueWrite(..) , OnlyOneUniqueKey(..) , onlyOneUniqueDef , AtLeastOneUniqueKey(..) , atLeastOneUniqueDef , NoUniqueKeysError , MultipleUniqueKeysError , getByValue , getByValueUniques , insertBy , insertUniqueEntity , replaceUnique , checkUnique , checkUniqueUpdateable , onlyUnique , defaultUpsertBy , defaultPutMany , persistUniqueKeyValues ) where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Function (on) import Data.List (deleteFirstsBy, (\\)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (catMaybes, isJust) import GHC.TypeLits (ErrorMessage(..)) import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistStore import Database.Persist.Types -- | Queries against 'Unique' keys (other than the id 'Key'). -- -- Please read the general Persistent documentation to learn how to create -- 'Unique' keys. -- -- Using this with an Entity without a Unique key leads to undefined -- behavior. A few of these functions require a /single/ 'Unique', so using -- an Entity with multiple 'Unique's is also undefined. In these cases -- persistent's goal is to throw an exception as soon as possible, but -- persistent is still transitioning to that. -- -- 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 -- | Get a record by unique key, if available. Returns also the identifier. -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>: -- -- > getBySpjName :: MonadIO m => ReaderT SqlBackend m (Maybe (Entity User)) -- > getBySpjName = getBy $ UniqueUserName "SPJ" -- -- > mSpjEnt <- getBySpjName -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will get this entity: -- -- > +----+------+-----+ -- > | id | name | age | -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getBy :: forall record m. (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) -- | Returns True if a record with this unique key exists, otherwise False. -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>: -- -- > existsBySpjName :: MonadIO m => ReaderT SqlBackend m Bool -- > existsBySpjName = existsBy $ UniqueUserName "SPJ" -- -- > spjEntExists <- existsBySpjName -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will return -- the value True. -- -- @since 2.14.5 existsBy :: forall record m. (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m Bool existsBy uniq = isJust <$> getBy uniq -- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for -- conflicts. You could instead optimistically attempt to perform the -- operation (e.g. 'replace' instead of 'replaceUnique'). However, -- -- * there is some fragility to trying to catch the correct exception and -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction. class (PersistUniqueRead backend, PersistStoreWrite backend) => PersistUniqueWrite backend where -- | Delete a specific record by unique key. Does nothing if no record -- matches. -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, -- -- > deleteBySpjName :: MonadIO m => ReaderT SqlBackend m () -- > deleteBySpjName = deleteBy UniqueUserName "SPJ" -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ deleteBy :: forall record m. (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, we try to insert the following two records: -- -- > linusId <- insertUnique $ User "Linus" 48 -- > spjId <- insertUnique $ User "SPJ" 90 -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |Linus |48 | -- > +-----+------+-----+ -- -- Linus's record was inserted to <#dataset-persist-unique-1 dataset-1>, while SPJ wasn't because SPJ already exists in <#dataset-persist-unique-1 dataset-1>. insertUnique :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum case conflict of Nothing -> Just `liftM` insert datum Just _ -> return Nothing -- | Same as 'insertUnique' but doesn't return a @Key@. -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, we try to insert the following two records: -- -- > linusId <- insertUnique_ $ User "Linus" 48 -- > spjId <- insertUnique_ $ User "SPJ" 90 -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |Linus |48 | -- > +-----+------+-----+ -- -- Linus's record was inserted to <#dataset-persist-unique-1 dataset-1>, while SPJ wasn't because SPJ already exists in <#dataset-persist-unique-1 dataset-1>. -- -- @since 2.14.5.0 insertUnique_ :: forall record m. (MonadIO m, PersistRecordBackend record backend, SafeToInsert record) => record -> ReaderT backend m (Maybe ()) insertUnique_ datum = do conflict <- checkUnique datum case conflict of Nothing -> Just `liftM` insert_ datum Just _ -> return Nothing -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. -- -- === __Example usage__ -- -- First, we try to explain 'upsert' using <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>. -- -- > upsertSpj :: MonadIO m => [Update User] -> ReaderT SqlBackend m (Maybe (Entity User)) -- > upsertSpj updates = upsert (User "SPJ" 999) updates -- -- > mSpjEnt <- upsertSpj [UserAge +=. 15] -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will produce this: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 -> 55| -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ -- -- > upsertX :: MonadIO m => [Update User] -> ReaderT SqlBackend m (Maybe (Entity User)) -- > upsertX updates = upsert (User "X" 999) updates -- -- > mXEnt <- upsertX [UserAge +=. 15] -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will produce this: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 | -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ -- > |3 |X |999 | -- > +-----+-----+--------+ -- -- Next, what if the schema has two uniqueness constraints? -- Let's check it out using <#schema-persist-unique-2 schema-2>: -- -- > mSpjEnt <- upsertSpj [UserAge +=. 15] -- -- This fails with a compile-time type error alerting us to the fact -- 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) => 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 upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * update the existing record that matches the given uniqueness constraint. -- -- === __Example usage__ -- -- We try to explain 'upsertBy' using <#schema-persist-unique-2 schema-2> and <#dataset-persist-unique-1 dataset-1>. -- -- > upsertBySpjName :: MonadIO m => User -> [Update User] -> ReaderT SqlBackend m (Entity User) -- > upsertBySpjName record updates = upsertBy (UniqueUserName "SPJ") record updates -- -- > mSpjEnt <- upsertBySpjName (Person "X" 999) [PersonAge += .15] -- -- The above query will alter <#dataset-persist-unique-1 dataset-1> to: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 -> 55| -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ -- -- > upsertBySimonAge :: MonadIO m => User -> [Update User] -> ReaderT SqlBackend m (Entity User) -- > upsertBySimonAge record updates = upsertBy (UniqueUserName "SPJ") record updates -- -- > mPhilipEnt <- upsertBySimonAge (User "X" 999) [UserName =. "Philip"] -- -- The above query will alter <#dataset-persist-unique-1 dataset-1> to: -- -- > +----+-----------------+-----+ -- > | id | name | age | -- > +----+-----------------+-----+ -- > | 1 | SPJ | 40 | -- > +----+-----------------+-----+ -- > | 2 | Simon -> Philip | 41 | -- > +----+-----------------+-----+ -- -- > upsertByUnknownName :: MonadIO m => User -> [Update User] -> ReaderT SqlBackend m (Entity User) -- > upsertByUnknownName record updates = upsertBy (UniqueUserName "Unknown") record updates -- -- > mXEnt <- upsertByUnknownName (User "X" 999) [UserAge +=. 15] -- -- This query will alter <#dataset-persist-unique-1 dataset-1> to: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -- > |3 |X |999 | -- > +-----+-----+-----+ upsertBy :: forall record m. (MonadIO m, PersistRecordBackend record 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 upsertBy = defaultUpsertBy -- | Put many records into db -- -- * insert new records that do not exist (or violate any unique constraints) -- * replace existing records (matching any unique constraint) -- -- @since 2.8.1 putMany :: 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 () putMany = defaultPutMany -- | This class is used to ensure that 'upsert' is only called on records -- that have a single 'Unique' key. The quasiquoter automatically generates -- working instances for appropriate records, and generates 'TypeError' -- instances for records that have 0 or multiple unique keys. -- -- @since 2.10.0 class PersistEntity record => OnlyOneUniqueKey record where onlyUniqueP :: record -> Unique record -- | Given a proxy for a 'PersistEntity' record, this returns the sole -- 'UniqueDef' for that entity. -- -- @since 2.13.0.0 onlyOneUniqueDef :: (OnlyOneUniqueKey record, Monad proxy) => proxy record -> UniqueDef onlyOneUniqueDef prxy = case getEntityUniques (entityDef prxy) of [uniq] -> uniq _ -> error "impossible due to OnlyOneUniqueKey constraint" -- | This is an error message. It is used when writing instances of -- 'OnlyOneUniqueKey' for an entity that has no unique keys. -- -- @since 2.10.0 type NoUniqueKeysError ty = '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 "to be defined on the entity." -- | This is an error message. It is used when an entity has multiple -- unique keys, and the function expects a single unique key. -- -- @since 2.10.0 type MultipleUniqueKeysError ty = 'Text "The entity " ':<>: 'ShowType ty ':<>: 'Text " has multiple unique keys." ':$$: '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 "appended that will allow you to select a unique key " ':<>: 'Text "for the operation." -- | This class is used to ensure that functions requring at least one -- unique key are not called with records that have 0 unique keys. The -- quasiquoter automatically writes working instances for appropriate -- entities, and generates 'TypeError' instances for records that have -- 0 unique keys. -- -- @since 2.10.0 class PersistEntity record => AtLeastOneUniqueKey record where requireUniquesP :: record -> NonEmpty (Unique record) -- | Given a proxy for a record that has an instance of -- 'AtLeastOneUniqueKey', this returns a 'NonEmpty' list of the -- 'UniqueDef's for that entity. -- -- @since 2.10.0 atLeastOneUniqueDef :: (AtLeastOneUniqueKey record, Monad proxy) => proxy record -> NonEmpty UniqueDef atLeastOneUniqueDef prxy = case getEntityUniques (entityDef prxy) of (x:xs) -> x :| xs _ -> error "impossible due to AtLeastOneUniqueKey record constraint" -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key is returned as 'Right'. -- -- === __Example usage__ -- -- With <#schema-persist-unique-2 schema-2> and <#dataset-persist-unique-1 dataset-1>, we have following lines of code: -- -- > l1 <- insertBy $ User "SPJ" 20 -- > l2 <- insertBy $ User "XXX" 41 -- > l3 <- insertBy $ User "SPJ" 40 -- > r1 <- insertBy $ User "XXX" 100 -- -- 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 ) => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val case res of Nothing -> Right `liftM` insert val Just z -> return $ Left z -- | Like 'insertEntity', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. -- -- @since 2.7.1 -- -- === __Example usage__ -- -- We use <#schema-persist-unique-2 schema-2> and <#dataset-persist-unique-1 dataset-1> here. -- -- > insertUniqueSpjEntity :: MonadIO m => ReaderT SqlBackend m (Maybe (Entity User)) -- > insertUniqueSpjEntity = insertUniqueEntity $ User "SPJ" 50 -- -- > mSpjEnt <- insertUniqueSpjEntity -- -- The above query results 'Nothing' as SPJ already exists. -- -- > insertUniqueAlexaEntity :: MonadIO m => ReaderT SqlBackend m (Maybe (Entity User)) -- > insertUniqueAlexaEntity = insertUniqueEntity $ User "Alexa" 3 -- -- > mAlexaEnt <- insertUniqueSpjEntity -- -- Because there's no such unique keywords of the given record, the above query when applied on <#dataset-persist-unique-1 dataset-1>, will produce this: -- -- > +----+-------+-----+ -- > | id | name | age | -- > +----+-------+-----+ -- > | 1 | SPJ | 40 | -- > +----+-------+-----+ -- > | 2 | Simon | 41 | -- > +----+-------+-----+ -- > | 3 | Alexa | 3 | -- > +----+-------+-----+ insertUniqueEntity :: forall record backend m . ( MonadIO m , PersistRecordBackend record backend , PersistUniqueWrite backend , SafeToInsert record ) => record -> ReaderT backend m (Maybe (Entity record)) insertUniqueEntity datum = fmap (\key -> Entity key datum) `liftM` insertUnique datum -- | Return the single unique key for a record. -- -- === __Example usage__ -- -- We use shcema-1 and <#dataset-persist-unique-1 dataset-1> here. -- -- > onlySimonConst :: MonadIO m => ReaderT SqlBackend m (Unique User) -- > onlySimonConst = onlyUnique $ User "Simon" 999 -- -- > mSimonConst <- onlySimonConst -- -- @mSimonConst@ would be Simon's uniqueness constraint. Note that -- @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 ) => record -> ReaderT backend m (Unique record) onlyUnique = pure . onlyUniqueP -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' record. Returns a record matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor. -- -- === __Example usage__ -- -- With <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1>, -- -- getBySpjValue :: MonadIO m => ReaderT SqlBackend m (Maybe (Entity User)) -- getBySpjValue = getByValue $ User "SPJ" 999 -- -- > mSpjEnt <- getBySpjValue -- -- The above query when applied on <#dataset-persist-unique-1 dataset-1>, will get this record: -- -- > +----+------+-----+ -- > | id | name | age | -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ getByValue :: 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 getByValueUniques (NEL.toList uniqs) -- | Retrieve a record from the database using the given unique keys. It -- will attempt to find a matching record for each 'Unique' in the list, -- and returns the first one that has a match. -- -- Returns 'Nothing' if you provide an empty list ('[]') or if no value -- matches in the database. -- -- @since 2.10.0 getByValueUniques :: 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 y <- getBy x case y of Nothing -> checkUniques xs Just z -> return $ Just z -- | Attempt to replace the record of the given key with the given new record. -- First query the unique fields to make sure the replacement maintains -- uniqueness constraints. -- -- Return 'Nothing' if the replacement was made. -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- @since 1.2.2.0 replaceUnique :: forall record backend m. ( MonadIO m , Eq (Unique record) , PersistRecordBackend record backend , PersistUniqueWrite backend ) => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where uniqueKeysNew = persistUniqueKeys datumNew replaceOriginal original = do conflict <- checkUniqueKeys changedKeys case conflict of Nothing -> replace key datumNew >> return Nothing (Just conflictingKey) -> return $ Just conflictingKey where changedKeys = uniqueKeysNew \\ uniqueKeysOriginal uniqueKeysOriginal = persistUniqueKeys original -- | Check whether there are any conflicts for unique keys with this entity and -- existing entities in the database. -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key -- -- === __Example usage__ -- -- We use <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1> here. -- -- This would be 'Nothing': -- -- > mAlanConst <- checkUnique $ User "Alan" 70 -- -- While this would be 'Just' because SPJ already exists: -- -- > mSpjConst <- checkUnique $ User "SPJ" 60 checkUnique :: forall record backend m. ( MonadIO m , PersistRecordBackend record backend , PersistUniqueRead backend) => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys checkUniqueKeys :: forall record backend m. ( MonadIO m , PersistUniqueRead backend , PersistRecordBackend record backend) => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do y <- getBy x case y of Nothing -> checkUniqueKeys xs Just _ -> return (Just x) -- | Check whether there are any conflicts for unique keys with this entity and -- existing entities in the database. -- -- Returns 'Nothing' if the entity would stay unique, and could thus safely be updated. -- on a conflict returns the conflicting key -- -- This is similar to 'checkUnique', except it's useful for updating - when the -- particular entity already exists, it would normally conflict with itself. -- This variant ignores those conflicts -- -- === __Example usage__ -- -- We use <#schema-persist-unique-1 schema-1> and <#dataset-persist-unique-1 dataset-1> here. -- -- This would be 'Nothing': -- -- > mAlanConst <- checkUnique $ User "Alan" 70 -- -- While this would be 'Just' because SPJ already exists: -- -- > mSpjConst <- checkUnique $ User "SPJ" 60 -- -- @since 2.11.0.0 checkUniqueUpdateable :: forall record backend m. ( MonadIO m , PersistRecordBackend record backend , PersistUniqueRead backend) => Entity record -> ReaderT backend m (Maybe (Unique record)) checkUniqueUpdateable (Entity key record) = checkUniqueKeysUpdateable key (persistUniqueKeys record) checkUniqueKeysUpdateable :: forall record backend m. ( MonadIO m , PersistUniqueRead backend , PersistRecordBackend record backend) => Key record -> [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeysUpdateable _ [] = return Nothing checkUniqueKeysUpdateable key (x:xs) = do y <- getBy x case y of Nothing -> checkUniqueKeysUpdateable key xs Just (Entity k _) | key == k -> checkUniqueKeysUpdateable key xs Just _ -> return (Just x) -- | The slow but generic 'upsertBy' implementation for any 'PersistUniqueRead'. -- * Lookup corresponding entities (if any) 'getBy'. -- * If the record exists, update using 'updateGet'. -- * If it does not exist, insert using 'insertEntity'. -- @since 2.11 defaultUpsertBy :: ( PersistEntityBackend record ~ BaseBackend backend , PersistEntity record , MonadIO m , PersistStoreWrite backend , PersistUniqueRead backend , SafeToInsert record ) => Unique record -- ^ uniqueness constraint to find by -> record -- ^ new record to insert -> [Update record] -- ^ updates to perform if the record already exists -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation defaultUpsertBy uniqueKey record updates = do mrecord <- getBy uniqueKey maybe (insertEntity record) (`updateGetEntity` updates) mrecord where updateGetEntity (Entity k _) upds = (Entity k) `liftM` (updateGet k upds) -- | The slow but generic 'putMany' implementation for any 'PersistUniqueRead'. -- * Lookup corresponding entities (if any) for each record using 'getByValue' -- * For pre-existing records, issue a 'replace' for each old key and new record -- * For new records, issue a bulk 'insertMany_' defaultPutMany :: 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 case persistUniqueKeys e of [] -> insertMany_ rsD _ -> go where go = do -- 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 -- 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 -- determine records to insert 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 -- insert `new` records insertMany_ rsNew -- replace existing records mapM_ (uncurry replace) krs -- | 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 = concatMap persistUniqueToValues . persistUniqueKeys persistent-2.14.6.0/Database/Persist/Class/PersistConfig.hs0000644000000000000000000000410514476403105021651 0ustar0000000000000000{-# LANGUAGE CPP #-} module Database.Persist.Class.PersistConfig ( PersistConfig (..) ) where import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Aeson (Value (Object)) import Data.Aeson.Types (Parser) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as AM #else import qualified Data.HashMap.Strict as AM #endif import Data.Kind (Type) -- | Represents a value containing all the configuration options for a specific -- backend. This abstraction makes it easier to write code that can easily swap -- backends. class PersistConfig c where type PersistConfigBackend c :: (Type -> Type) -> Type -> Type type PersistConfigPool c -- | Load the config settings from a 'Value', most likely taken from a YAML -- config file. loadConfig :: Value -> Parser c -- | Modify the config settings based on environment variables. applyEnv :: c -> IO c applyEnv = return -- | Create a new connection pool based on the given config settings. 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 instance ( PersistConfig c1 , PersistConfig c2 , PersistConfigPool c1 ~ PersistConfigPool c2 , PersistConfigBackend c1 ~ PersistConfigBackend c2 ) => PersistConfig (Either c1 c2) where type PersistConfigBackend (Either c1 c2) = PersistConfigBackend c1 type PersistConfigPool (Either c1 c2) = PersistConfigPool c1 loadConfig (Object o) = case AM.lookup "left" o of Just v -> Left <$> loadConfig v Nothing -> case AM.lookup "right" o of Just v -> Right <$> loadConfig v Nothing -> fail "PersistConfig for Either: need either a left or right" loadConfig _ = fail "PersistConfig for Either: need an object" createPoolConfig = either createPoolConfig createPoolConfig runPool (Left c) = runPool c runPool (Right c) = runPool c persistent-2.14.6.0/Database/Persist/Class/PersistField.hs0000644000000000000000000005554414476403105021504 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances, GeneralizedNewtypeDeriving #-} module Database.Persist.Class.PersistField ( PersistField (..) , getPersistMap , OverflowNatural(..) ) where import Control.Arrow (second) import Control.Monad ((<=<)) import Control.Applicative ((<|>)) import qualified Data.Aeson as A import Data.ByteString.Char8 (ByteString, unpack, readInt) import qualified Data.ByteString.Lazy as L import Data.Fixed import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.IntMap as IM import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as M 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 qualified Data.Vector as V import Data.Word (Word, Word8, Word16, Word32, Word64) import Numeric.Natural (Natural) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) import GHC.TypeLits import Database.Persist.Types.Base import Data.Time (Day(..), TimeOfDay, UTCTime, parseTimeM) import Data.Time (defaultTimeLocale) #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__ -- -- ===== Simple Newtype -- -- You can use @newtype@ to add more type safety/readability to a basis type like 'ByteString'. In these cases, just derive 'PersistField' and @PersistFieldSql@: -- -- @ -- {-\# LANGUAGE GeneralizedNewtypeDeriving #-} -- -- newtype HashedPassword = HashedPassword 'ByteString' -- deriving (Eq, Show, 'PersistField', PersistFieldSql) -- @ -- -- ===== Smart Constructor Newtype -- -- In this example, we create a 'PersistField' instance for a newtype following the "Smart Constructor" pattern. -- -- @ -- {-\# LANGUAGE GeneralizedNewtypeDeriving #-} -- import qualified "Data.Text" as T -- import qualified "Data.Char" as C -- -- -- | An American Social Security Number -- newtype SSN = SSN 'Text' -- deriving (Eq, Show, PersistFieldSql) -- -- mkSSN :: 'Text' -> 'Either' 'Text' SSN -- mkSSN t = if (T.length t == 9) && (T.all C.isDigit t) -- then 'Right' $ SSN t -- else 'Left' $ "Invalid SSN: " <> t -- -- instance 'PersistField' SSN where -- 'toPersistValue' (SSN t) = 'PersistText' t -- 'fromPersistValue' ('PersistText' t) = mkSSN t -- -- Handle cases where the database does not give us PersistText -- 'fromPersistValue' x = 'Left' $ "File.hs: When trying to deserialize an SSN: expected PersistText, received: " <> T.pack (show x) -- @ -- -- Tips: -- -- * This file contain dozens of 'PersistField' instances you can look at for examples. -- * Typically custom 'PersistField' instances will only accept a single 'PersistValue' constructor in 'fromPersistValue'. -- * Internal 'PersistField' instances accept a wide variety of 'PersistValue's to accomodate e.g. storing booleans as integers, booleans or strings. -- * If you're making a custom instance and using a SQL database, you'll also need @PersistFieldSql@ to specify the type of the database column. class PersistField a where toPersistValue :: a -> PersistValue fromPersistValue :: PersistValue -> Either T.Text a #ifndef NO_OVERLAP instance {-# OVERLAPPING #-} PersistField [Char] where toPersistValue = PersistText . T.pack fromPersistValue (PersistText s) = Right $ T.unpack s fromPersistValue (PersistByteString bs) = Right $ T.unpack $ TE.decodeUtf8With TERR.lenientDecode bs fromPersistValue (PersistInt64 i) = Right $ Prelude.show i fromPersistValue (PersistDouble d) = Right $ Prelude.show d fromPersistValue (PersistRational r) = Right $ Prelude.show r fromPersistValue (PersistDay d) = Right $ Prelude.show d fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d fromPersistValue PersistNull = Left $ T.pack "Unexpected null" fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String" fromPersistValue (PersistLiteral_ _ _) = Left $ T.pack "Cannot convert PersistLiteral_ to String" fromPersistValue (PersistArray _) = Left $ T.pack "Cannot convert PersistArray to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif instance PersistField ByteString where toPersistValue = PersistByteString fromPersistValue (PersistByteString bs) = Right bs fromPersistValue x = TE.encodeUtf8 <$> fromPersistValue x instance PersistField T.Text where toPersistValue = PersistText fromPersistValue = fromPersistValueText instance PersistField TL.Text where toPersistValue = toPersistValue . TL.toStrict fromPersistValue = fmap TL.fromStrict . fromPersistValue instance PersistField Html where toPersistValue = PersistText . TL.toStrict . renderHtml fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle fromPersistValue x = Left $ fromPersistValueError "Int" "integer" x instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i Just (i,extra) -> Left $ extraInputError "Int64" bs i extra Nothing -> Left $ intParseError "Int64" bs fromPersistValue x = Left $ fromPersistValueError "Int8" "integer" x instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i Just (i,extra) -> Left $ extraInputError "Int64" bs i extra Nothing -> Left $ intParseError "Int64" bs fromPersistValue x = Left $ fromPersistValueError "Int16" "integer" x instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i Just (i,extra) -> Left $ extraInputError "Int64" bs i extra Nothing -> Left $ intParseError "Int64" bs fromPersistValue x = Left $ fromPersistValueError "Int32" "integer" x instance PersistField Int64 where toPersistValue = PersistInt64 fromPersistValue (PersistInt64 i) = Right i fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i Just (i,extra) -> Left $ extraInputError "Int64" bs i extra Nothing -> Left $ intParseError "Int64" bs fromPersistValue x = Left $ fromPersistValueError "Int64" "integer" x extraInputError :: (Show result) => Text -- ^ Haskell type -> ByteString -- ^ Original bytestring -> result -- ^ Integer result -> ByteString -- ^ Extra bytestring -> Text -- ^ Error message extraInputError haskellType original result extra = T.concat [ "Parsed " , TE.decodeUtf8 original , " into Haskell type `" , haskellType , "` with value" , T.pack $ show result , "but had extra input: " , TE.decodeUtf8 extra ] intParseError :: Text -- ^ Haskell type -> ByteString -- ^ Original bytestring -> Text -- ^ Error message intParseError haskellType original = T.concat [ "Failed to parse Haskell type `" , haskellType , " from " , TE.decodeUtf8 original ] instance PersistField Data.Word.Word where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Word" "integer" x instance PersistField Word8 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Word8" "integer" x instance PersistField Word16 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Word16" "integer" x instance PersistField Word32 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Word32" "integer" x instance PersistField Word64 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Word64" "integer" x instance PersistField Double where toPersistValue = PersistDouble fromPersistValue (PersistDouble d) = Right d fromPersistValue (PersistRational r) = Right $ fromRational r fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Double" "double, rational, or integer" x instance (HasResolution a) => PersistField (Fixed a) where 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" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ fromPersistValueError "Fixed" "rational, string, double, or integer" x instance PersistField Rational where toPersistValue = PersistRational 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)" 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 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 instance PersistField Day where toPersistValue = PersistDay fromPersistValue (PersistDay d) = Right d fromPersistValue (PersistInt64 i) = Right $ ModifiedJulianDay $ toInteger i fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ fromPersistValueParseError "Day" x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d _ -> Left $ fromPersistValueParseError "Day" x fromPersistValue x = Left $ fromPersistValueError "Day" "day, integer, string or bytestring" x instance PersistField TimeOfDay where toPersistValue = PersistTimeOfDay fromPersistValue (PersistTimeOfDay d) = Right d fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ fromPersistValueParseError "TimeOfDay" x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (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 #ifdef HIGH_PRECISION_DATE fromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i #endif fromPersistValue x@(PersistText t) = let s = T.unpack t in case NonEmpty.nonEmpty (reads s) of Nothing -> case parse8601 s <|> parsePretty s of Nothing -> Left $ fromPersistValueParseError "UTCTime" x Just x' -> Right x' Just matches -> -- The 'Read UTCTime' instance in newer versions of 'time' is -- more flexible when parsing UTCTime strings and will return -- UTCTimes with different microsecond parsings. The last result -- here contains the parsed UTCTime with as much microsecond -- precision parsed as posssible. Right $ fst $ NonEmpty.last matches where #if MIN_VERSION_time(1,5,0) parseTime' = parseTimeM True defaultTimeLocale #else 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 -- reasonable types for this. -- -- The instance for 'Natural' used the 'Int64' underlying type, which will -- cause underflow and overflow errors. This type has the exact same code -- in the instances, and will work seamlessly. -- -- A more appropriate type for this is the 'Word' series of types from -- "Data.Word". These have a bounded size, are guaranteed to be -- non-negative, and are quite efficient for the database to store. -- -- @since 2.11.0 newtype OverflowNatural = OverflowNatural { unOverflowNatural :: Natural } deriving (Eq, Show, Ord, Num) instance TypeError ( 'Text "The instance of PersistField for the Natural type was removed." ':$$: 'Text "Please see the documentation for OverflowNatural if you want to " ':$$: 'Text "continue using the old behavior or want to see documentation on " ':$$: 'Text "why the instance was removed." ':$$: 'Text "" ':$$: 'Text "This error instance will be removed in a future release." ) => PersistField Natural where toPersistValue = undefined fromPersistValue = undefined instance PersistField OverflowNatural where toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral . unOverflowNatural fromPersistValue x = case (fromPersistValue x :: Either Text Int64) of Left err -> Left $ T.replace "Int64" "OverflowNatural" err Right int -> Right $ OverflowNatural $ fromIntegral int -- TODO use bimap? instance PersistField a => PersistField (Maybe a) where toPersistValue Nothing = PersistNull toPersistValue (Just a) = toPersistValue a fromPersistValue PersistNull = Right Nothing fromPersistValue x = Just <$> fromPersistValue x instance {-# OVERLAPPABLE #-} PersistField a => PersistField [a] where toPersistValue = PersistList . fmap toPersistValue fromPersistValue (PersistList l) = fromPersistList l fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) fromPersistValue (PersistByteString bs) | Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values -- avoid the need for a migration to fill in empty lists. -- also useful when Persistent is not the only one filling in the data 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 (Ord a, PersistField a) => PersistField (S.Set a) where toPersistValue = PersistList . fmap toPersistValue . S.toList fromPersistValue (PersistList list) = S.fromList <$> fromPersistList list fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) fromPersistValue (PersistByteString bs) | Just values <- A.decode' (L.fromChunks [bs]) = S.fromList <$> fromPersistList values 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] 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 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 toPersistValue = PersistMap . fmap (second toPersistValue) . M.toList fromPersistValue = fromPersistMap <=< getPersistMap instance PersistField PersistValue where toPersistValue = id fromPersistValue = Right 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 -- 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 -- | 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 (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 instance PersistField Checkmark where toPersistValue Active = PersistBool True toPersistValue Inactive = PersistNull 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'." fromPersistValue (PersistBool False) = Left $ T.pack "PersistField Checkmark: found unexpected FALSE value" fromPersistValue 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." ] 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) ] persistent-2.14.6.0/Database/Persist/Class/PersistStore.hs0000644000000000000000000006540314507117603021550 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExplicitForAll #-} module Database.Persist.Class.PersistStore ( HasPersistBackend (..) , withBaseBackend , IsPersistBackend (..) , PersistRecordBackend , liftPersist , PersistCore (..) , PersistStoreRead (..) , PersistStoreWrite (..) , getEntity , getJust , getJustEntity , belongsTo , belongsToJust , insertEntity , insertRecord , ToBackendKey(..) , BackendCompatible(..) , withCompatibleBackend ) where import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (MonadReader (ask), runReaderT) import Control.Monad.Trans.Reader (ReaderT, withReaderT) import qualified Data.Aeson as A import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Text as T import GHC.Stack import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.Types -- | Class which allows the plucking of a @BaseBackend backend@ from some larger type. -- For example, -- @ -- instance HasPersistBackend (SqlReadBackend, Int) where -- type BaseBackend (SqlReadBackend, Int) = SqlBackend -- persistBackend = unSqlReadBackend . fst -- @ class HasPersistBackend backend where type BaseBackend backend persistBackend :: backend -> BaseBackend backend -- | Run a query against a larger backend by plucking out @BaseBackend backend@ -- -- This is a helper for reusing existing queries when expanding the backend type. -- -- @since 2.12.0 withBaseBackend :: (HasPersistBackend backend) => ReaderT (BaseBackend backend) m a -> ReaderT backend m a withBaseBackend = withReaderT persistBackend -- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@. -- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@. class (HasPersistBackend backend) => IsPersistBackend backend where -- | This function is how we actually construct and tag a backend as having read or write capabilities. -- It should be used carefully and only when actually constructing a @backend@. Careless use allows us -- to accidentally run a write query against a read-only database. mkPersistBackend :: BaseBackend backend -> backend -- NB: there is a deliberate *lack* of an equivalent to 'withBaseBackend' for -- 'IsPersistentBackend'. We don't want it to be easy for the user to construct -- a backend when they're not meant to. -- | This class witnesses that two backend are compatible, and that you can -- convert from the @sub@ backend into the @sup@ backend. This is similar -- to the 'HasPersistBackend' and 'IsPersistBackend' classes, but where you -- don't want to fix the type associated with the 'PersistEntityBackend' of -- a record. -- -- Generally speaking, where you might have: -- -- @ -- foo :: -- ( 'PersistEntity' record -- , 'PersistEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @ -- -- this can be replaced with: -- -- @ -- foo :: -- ( 'PersistEntity' record, -- , 'PersistEntityBackend' record ~ backend -- , 'BackendCompatible' 'SqlBackend' backend -- ) -- @ -- -- This works for 'SqlReadBackend' because of the @instance 'BackendCompatible' 'SqlBackend' 'SqlReadBackend'@, without needing to go through the 'BaseBackend' type family. -- -- Likewise, functions that are currently hardcoded to use 'SqlBackend' can be generalized: -- -- @ -- -- before: -- asdf :: 'ReaderT' 'SqlBackend' m () -- asdf = pure () -- -- -- after: -- asdf' :: 'BackendCompatible' SqlBackend backend => ReaderT backend m () -- asdf' = 'withCompatibleBackend' asdf -- @ -- -- @since 2.7.1 class BackendCompatible sup sub where projectBackend :: sub -> sup -- | Run a query against a compatible backend, by projecting the backend -- -- This is a helper for using queries which run against a specific backend type -- that your backend is compatible with. -- -- @since 2.12.0 withCompatibleBackend :: (BackendCompatible sup sub) => ReaderT sup m a -> ReaderT sub m a withCompatibleBackend = withReaderT projectBackend -- | A convenient alias for common type signatures type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) liftPersist :: (MonadIO m, MonadReader backend m) => ReaderT backend IO b -> m b liftPersist f = do env <- ask liftIO $ runReaderT f env -- | 'ToBackendKey' converts a 'PersistEntity' 'Key' into a 'BackendKey' -- This can be used by each backend to convert between a 'Key' and a plain -- Haskell type. For Sql, that is done with 'toSqlKey' and 'fromSqlKey'. -- -- By default, a 'PersistEntity' uses the default 'BackendKey' for its Key -- and is an instance of ToBackendKey -- -- 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 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 -- | Get a record by identifier, if available. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > getSpj :: MonadIO m => ReaderT SqlBackend m (Maybe User) -- > getSpj = get spjId -- -- > mspj <- getSpj -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will get this: -- -- > +------+-----+ -- > | name | age | -- > +------+-----+ -- > | SPJ | 40 | -- > +------+-----+ 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. -- -- @since 2.8.1 -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>: -- -- > getUsers :: MonadIO m => ReaderT SqlBackend m (Map (Key User) User) -- > getUsers = getMany allkeys -- -- > musers <- getUsers -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will get these records: -- -- > +----+-------+-----+ -- > | id | name | age | -- > +----+-------+-----+ -- > | 1 | SPJ | 40 | -- > +----+-------+-----+ -- > | 2 | Simon | 41 | -- > +----+-------+-----+ getMany :: 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 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 -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id). -- -- === __Example usage__ -- -- Using <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, let's insert a new user 'John'. -- -- > insertJohn :: MonadIO m => ReaderT SqlBackend m (Key User) -- > insertJohn = insert $ User "John" 30 -- -- > johnId <- insertJohn -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+ 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@. -- -- === __Example usage__ -- -- with <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertJohn :: MonadIO m => ReaderT SqlBackend m (Key User) -- > insertJohn = insert_ $ User "John" 30 -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+ 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. -- -- If you don't need the inserted 'Key's, use 'insertMany_'. -- -- The MongoDB and PostgreSQL backends insert all records and -- retrieve their keys in one database query. -- -- The SQLite and MySQL backends use the slow, default implementation of -- @mapM insert@. -- -- === __Example usage__ -- -- with <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertUsers :: MonadIO m => ReaderT SqlBackend m [Key User] -- > insertUsers = insertMany [User "John" 30, User "Nick" 32, User "Jane" 20] -- -- > userIds <- insertUsers -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+ -- > |4 |Nick |32 | -- > +-----+------+-----+ -- > |5 |Jane |20 | -- > +-----+------+-----+ 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. -- -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in -- one database query. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertUsers_ :: MonadIO m => ReaderT SqlBackend m () -- > insertUsers_ = insertMany_ [User "John" 30, User "Nick" 32, User "Jane" 20] -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |John |30 | -- > +-----+------+-----+ -- > |4 |Nick |32 | -- > +-----+------+-----+ -- > |5 |Jane |20 | -- > +-----+------+-----+ 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. -- -- Useful when migrating data from one entity to another -- and want to preserve ids. -- -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in -- one database query. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertUserEntityMany :: MonadIO m => ReaderT SqlBackend m () -- > insertUserEntityMany = insertEntityMany [SnakeEntity, EvaEntity] -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |Snake |38 | -- > +-----+------+-----+ -- > |4 |Eva |38 | -- > +-----+------+-----+ 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. -- -- === __Example usage__ -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertAliceKey :: MonadIO m => Key User -> ReaderT SqlBackend m () -- > insertAliceKey key = insertKey key $ User "Alice" 20 -- -- > insertAliceKey $ UserKey {unUserKey = SqlBackendKey {unSqlBackendKey = 3}} -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |Alice |20 | -- > +-----+------+-----+ 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 -- exist then a new record will be inserted. -- -- === __Example usage__ -- -- We try to explain 'upsertBy' using <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>. -- -- First, we insert Philip to <#dataset-persist-store-1 dataset-1>. -- -- > insertPhilip :: MonadIO m => ReaderT SqlBackend m (Key User) -- > insertPhilip = insert $ User "Philip" 42 -- -- > philipId <- insertPhilip -- -- This query will produce: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |Philip|42 | -- > +-----+------+-----+ -- -- > repsertHaskell :: MonadIO m => Key record -> ReaderT SqlBackend m () -- > repsertHaskell id = repsert id $ User "Haskell" 81 -- -- > repsertHaskell philipId -- -- This query will replace Philip's record with Haskell's one: -- -- > +-----+-----------------+--------+ -- > |id |name |age | -- > +-----+-----------------+--------+ -- > |1 |SPJ |40 | -- > +-----+-----------------+--------+ -- > |2 |Simon |41 | -- > +-----+-----------------+--------+ -- > |3 |Philip -> Haskell|42 -> 81| -- > +-----+-----------------+--------+ -- -- 'repsert' inserts the given record if the key doesn't exist. -- -- > repsertXToUnknown :: MonadIO m => ReaderT SqlBackend m () -- > repsertXToUnknown = repsert unknownId $ User "X" 999 -- -- For example, applying the above query to <#dataset-persist-store-1 dataset-1> will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |3 |X |999 | -- > +-----+------+-----+ repsert :: forall record m. (MonadIO m, PersistRecordBackend record backend) => Key record -> record -> ReaderT backend m () -- | Put many entities into the database. -- -- Batch version of 'repsert' for SQL backends. -- -- Useful when migrating data from one entity to another -- and want to preserve ids. -- -- @since 2.8.1 -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > repsertManyUsers :: MonadIO m =>ReaderT SqlBackend m () -- > repsertManyusers = repsertMany [(simonId, User "Philip" 20), (unknownId999, User "Mr. X" 999)] -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+----------------+---------+ -- > |id |name |age | -- > +-----+----------------+---------+ -- > |1 |SPJ |40 | -- > +-----+----------------+---------+ -- > |2 |Simon -> Philip |41 -> 20 | -- > +-----+----------------+---------+ -- > |999 |Mr. X |999 | -- > +-----+----------------+---------+ repsertMany :: forall record m. (MonadIO m, PersistRecordBackend record backend) => [(Key record, record)] -> ReaderT backend m () repsertMany = mapM_ (uncurry repsert) -- | Replace the record in the database with the given -- key. Note that the result is undefined if such record does -- not exist, so you must use 'insertKey' or 'repsert' in -- these cases. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1 schama-1> and <#dataset-persist-store-1 dataset-1>, -- -- > replaceSpj :: MonadIO m => User -> ReaderT SqlBackend m () -- > replaceSpj record = replace spjId record -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |Mike |45 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ 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. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > deleteSpj :: MonadIO m => ReaderT SqlBackend m () -- > deleteSpj = delete spjId -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ delete :: forall record m. (MonadIO m, PersistRecordBackend record backend) => Key record -> ReaderT backend m () -- | Update individual fields on a specific record. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > updateSpj :: MonadIO m => [Update User] -> ReaderT SqlBackend m () -- > updateSpj updates = update spjId updates -- -- > updateSpj [UserAge +=. 100] -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |140 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ 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. -- -- Note that this function will throw an exception if the given key is not -- found in the database. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > updateGetSpj :: MonadIO m => [Update User] -> ReaderT SqlBackend m User -- > updateGetSpj updates = updateGet spjId updates -- -- > spj <- updateGetSpj [UserAge +=. 100] -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |140 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ 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. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > getJustSpj :: MonadIO m => ReaderT SqlBackend m User -- > getJustSpj = getJust spjId -- -- > spj <- getJust spjId -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will get this record: -- -- > +----+------+-----+ -- > | id | name | age | -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ -- -- > getJustUnknown :: MonadIO m => ReaderT SqlBackend m User -- > getJustUnknown = getJust unknownId -- -- 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 -- | Same as 'getJust', but returns an 'Entity' instead of just the record. -- -- @since 2.6.1 -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > getJustEntitySpj :: MonadIO m => ReaderT SqlBackend m (Entity User) -- > getJustEntitySpj = getJustEntity spjId -- -- > spjEnt <- getJustEntitySpj -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will get this entity: -- -- > +----+------+-----+ -- > | id | name | age | -- > +----+------+-----+ -- > | 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 key = do 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 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 getForeignKey model = getJust $ getForeignKey model -- | Like @insert@, but returns the complete @Entity@. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertHaskellEntity :: MonadIO m => ReaderT SqlBackend m (Entity User) -- > insertHaskellEntity = insertEntity $ User "Haskell" 81 -- -- > haskellEnt <- insertHaskellEntity -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +----+---------+-----+ -- > | id | name | age | -- > +----+---------+-----+ -- > | 1 | SPJ | 40 | -- > +----+---------+-----+ -- > | 2 | Simon | 41 | -- > +----+---------+-----+ -- > | 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 e = do eid <- insert e Maybe.fromMaybe (error errorMessage) <$> getEntity eid where errorMessage = "persistent: failed to get record from database despite receiving key from the database" -- | Like @get@, but returns the complete @Entity@. -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > getSpjEntity :: MonadIO m => ReaderT SqlBackend m (Maybe (Entity User)) -- > getSpjEntity = getEntity spjId -- -- > mSpjEnt <- getSpjEntity -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will get this entity: -- -- > +----+------+-----+ -- > | id | name | age | -- > +----+------+-----+ -- > | 1 | SPJ | 40 | -- > +----+------+-----+ 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 -- | Like 'insertEntity' but just returns the record instead of 'Entity'. -- -- @since 2.6.1 -- -- === __Example usage__ -- -- With <#schema-persist-store-1 schema-1> and <#dataset-persist-store-1 dataset-1>, -- -- > insertDaveRecord :: MonadIO m => ReaderT SqlBackend m User -- > insertDaveRecord = insertRecord $ User "Dave" 50 -- -- > dave <- insertDaveRecord -- -- The above query when applied on <#dataset-persist-store-1 dataset-1>, will produce this: -- -- > +-----+------+-----+ -- > |id |name |age | -- > +-----+------+-----+ -- > |1 |SPJ |40 | -- > +-----+------+-----+ -- > |2 |Simon |41 | -- > +-----+------+-----+ -- > |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 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 persistent-2.14.6.0/Database/Persist/Compatible.hs0000644000000000000000000000032414476403105020103 0ustar0000000000000000module Database.Persist.Compatible ( Compatible(..) , makeCompatibleInstances , makeCompatibleKeyInstances ) where import Database.Persist.Compatible.Types import Database.Persist.Compatible.TH persistent-2.14.6.0/Database/Persist/Types/Base.hs0000644000000000000000000005734614507124116020017 0ustar0000000000000000{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Database.Persist.Types.Base ( module Database.Persist.Types.Base -- * Re-exports , PersistValue(..) , fromPersistValueText , LiteralType(..) ) where import Control.Exception (Exception) import Data.Char (isSpace) 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 Web.HttpApiData ( FromHttpApiData(..) , ToHttpApiData(..) , parseBoundedTextData , showTextData ) import Web.PathPieces (PathPiece(..)) -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` -- instance on pre-1.2.4 versions of `text` import Instances.TH.Lift () import Database.Persist.Names import Database.Persist.PersistValue -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of -- record may appear at most once, but other kinds of records may -- appear any number of times. -- -- /NOTE:/ You need to mark any @Checkmark@ fields as @nullable@ -- (see the following example). -- -- For example, suppose there's a @Location@ entity that -- represents where a user has lived: -- -- @ -- Location -- user UserId -- name Text -- current Checkmark nullable -- -- UniqueLocation user current -- @ -- -- The @UniqueLocation@ constraint allows any number of -- 'Inactive' @Location@s to be @current@. However, there may be -- at most one @current@ @Location@ per user (i.e., either zero -- or one per user). -- -- This data type works because of the way that SQL treats -- @NULL@able fields within uniqueness constraints. The SQL -- standard says that @NULL@ values should be considered -- different, so we represent 'Inactive' as SQL @NULL@, thus -- allowing any number of 'Inactive' records. On the other hand, -- we represent 'Active' as @TRUE@, so the uniqueness constraint -- will disallow more than one 'Active' record. -- -- /Note:/ There may be DBMSs that do not respect the SQL -- standard's treatment of @NULL@ values on uniqueness -- constraints, please check if this data type works before -- relying on it. -- -- The SQL @BOOLEAN@ type is used because it's the smallest data -- 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. deriving (Eq, Ord, Read, Show, Enum, Bounded) instance ToHttpApiData Checkmark where toUrlPiece = showTextData instance FromHttpApiData Checkmark where parseUrlPiece = parseBoundedTextData instance PathPiece Checkmark where toPathPiece Active = "active" toPathPiece Inactive = "inactive" fromPathPiece "active" = Just Active fromPathPiece "inactive" = Just Inactive fromPathPiece _ = Nothing data IsNullable = Nullable !WhyNullable | NotNullable deriving (Eq, Show) fieldAttrsContainsNullable :: [FieldAttr] -> IsNullable fieldAttrsContainsNullable s | FieldAttrMaybe `elem` s = Nullable ByMaybeAttr | FieldAttrNullable `elem` s = Nullable ByNullableAttr | otherwise = NotNullable -- | The reason why a field is 'nullable' is very important. A -- field that is nullable because of a @Maybe@ tag will have its -- type changed from @A@ to @Maybe A@. OTOH, a field that is -- nullable because of a @nullable@ tag will remain with the same -- type. data WhyNullable = ByMaybeAttr | ByNullableAttr deriving (Eq, Show) -- | An 'EntityDef' represents the information that @persistent@ knows -- about an Entity. It uses this information to generate the Haskell -- datatype, the SQL migrations, and other relevant conversions. data EntityDef = EntityDef { entityHaskell :: !EntityNameHS -- ^ The name of the entity as Haskell understands it. , entityDB :: !EntityNameDB -- ^ The name of the database table corresponding to the entity. , entityId :: !EntityIdDef -- ^ The entity's primary key or identifier. , 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] -- ^ 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] -- ^ 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 -- ^ Whether or not this entity represents a sum type in the database. , entityComments :: !(Maybe Text) -- ^ Optional comments on the entity. -- -- @since 2.10.0 } deriving (Show, Eq, Read, Ord, Lift) -- | The definition for the entity's primary key ID. -- -- @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 deriving (Show, Eq, Read, Ord, Lift) -- | Return the @['FieldDef']@ for the entity keys. entitiesPrimary :: EntityDef -> NonEmpty FieldDef entitiesPrimary t = case entityId t of EntityIdNaturalKey fds -> compositeFields fds EntityIdField fd -> pure fd entityPrimary :: EntityDef -> Maybe CompositeDef entityPrimary t = case entityId t of EntityIdNaturalKey c -> Just c _ -> Nothing entityKeyFields :: EntityDef -> NonEmpty FieldDef entityKeyFields = entitiesPrimary -- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key -- columns for an 'EntityDef'. keyAndEntityFields :: EntityDef -> NonEmpty FieldDef keyAndEntityFields ent = keyWithFields (entityId ent) fields where fields = filter isHaskellField $ entityFields ent -- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key -- columns for an 'EntityDef' including those fields that are marked as -- 'MigrationOnly' (and therefore only present in the database) or -- 'SafeToRemove' (and a migration will drop the column if it exists in the -- database). -- -- For fields on the Haskell type use 'keyAndEntityFieldsDatabase' -- -- @since 2.14.6.0 keyAndEntityFieldsDatabase :: EntityDef -> NonEmpty FieldDef keyAndEntityFieldsDatabase ent = keyWithFields (entityId ent) fields where fields = entityFields ent keyWithFields :: EntityIdDef -> [FieldDef] -> NonEmpty FieldDef keyWithFields entId fields = case entId of EntityIdField fd -> fd :| fields EntityIdNaturalKey _ -> case NEL.nonEmpty fields of Nothing -> error $ mconcat [ "persistent internal guarantee failed: entity is " , "defined with an entityId = EntityIdNaturalKey, " , "but somehow doesn't have any entity fields." ] Just xs -> xs type ExtraLine = [Text] type Attr = Text -- | Attributes that may be attached to fields that can affect migrations -- and serialization in backend-specific ways. -- -- While we endeavor to, we can't forsee all use cases for all backends, -- and so 'FieldAttr' is extensible through its constructor 'FieldAttrOther'. -- -- @since 2.11.0.0 data FieldAttr = 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. deriving (Show, Eq, Read, Ord, Lift) -- | Parse raw field attributes into structured form. Any unrecognized -- attributes will be preserved, identically as they are encountered, -- as 'FieldAttrOther' values. -- -- @since 2.11.0.0 parseFieldAttrs :: [Text] -> [FieldAttr] parseFieldAttrs = fmap $ \case "Maybe" -> FieldAttrMaybe "nullable" -> FieldAttrNullable "MigrationOnly" -> FieldAttrMigrationOnly "SafeToRemove" -> FieldAttrSafeToRemove "noreference" -> FieldAttrNoreference raw | Just x <- T.stripPrefix "reference=" raw -> FieldAttrReference x | Just x <- T.stripPrefix "constraint=" raw -> FieldAttrConstraint x | Just x <- T.stripPrefix "default=" raw -> FieldAttrDefault x | Just x <- T.stripPrefix "sqltype=" raw -> FieldAttrSqltype x | Just x <- T.stripPrefix "maxlen=" raw -> case reads (T.unpack x) of [(n, s)] | all isSpace s -> FieldAttrMaxlen n _ -> error $ "Could not parse maxlen field with value " <> show raw | Just x <- T.stripPrefix "sql=" raw -> FieldAttrSql x | otherwise -> FieldAttrOther raw -- | A 'FieldType' describes a field parsed from the QuasiQuoter and is -- used to determine the Haskell type in the generated code. -- -- @name Text@ parses into @FTTypeCon Nothing "Text"@ -- -- @name T.Text@ parses into @FTTypeCon (Just "T" "Text")@ -- -- @name (Jsonb User)@ parses into: -- -- @ -- FTApp (FTTypeCon Nothing "Jsonb") (FTTypeCon Nothing "User") -- @ data FieldType = FTTypeCon (Maybe Text) Text -- ^ Optional module and name. | FTLit FieldTypeLit | FTTypePromoted Text | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord, Lift) data FieldTypeLit = IntTypeLit Integer | TextTypeLit Text deriving (Show, Eq, Read, Ord, Lift) isFieldNotGenerated :: FieldDef -> Bool isFieldNotGenerated = isNothing . fieldGenerated -- | There are 3 kinds of references -- 1) composite (to fields that exist in the record) -- 2) single field -- 3) embedded data ReferenceDef = NoReference | ForeignRef !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 | EmbedRef EntityNameHS | SelfReference -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311). deriving (Show, Eq, Read, Ord, Lift) -- | An EmbedEntityDef is the same as an EntityDef -- But it is only used for fieldReference -- so it only has data needed for embedding data EmbedEntityDef = EmbedEntityDef { embeddedHaskell :: EntityNameHS , embeddedFields :: [EmbedFieldDef] } deriving (Show, Eq, Read, Ord, Lift) -- | An EmbedFieldDef is the same as a FieldDef -- But it is only used for embeddedFields -- so it only has data needed for embedding data EmbedFieldDef = EmbedFieldDef { emFieldDB :: FieldNameDB , emFieldEmbed :: Maybe (Either SelfEmbed EntityNameHS) } deriving (Show, Eq, Read, Ord, Lift) data SelfEmbed = SelfEmbed deriving (Show, Eq, Read, Ord, Lift) -- | Returns 'True' if the 'FieldDef' does not have a 'MigrationOnly' or -- 'SafeToRemove' flag from the QuasiQuoter. -- -- @since 2.13.0.0 isHaskellField :: FieldDef -> Bool isHaskellField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd && FieldAttrSafeToRemove `notElem` fieldAttrs fd toEmbedEntityDef :: EntityDef -> EmbedEntityDef toEmbedEntityDef ent = embDef where embDef = EmbedEntityDef { embeddedHaskell = entityHaskell ent , embeddedFields = map toEmbedFieldDef $ filter isHaskellField $ entityFields ent } toEmbedFieldDef :: FieldDef -> EmbedFieldDef toEmbedFieldDef field = EmbedFieldDef { emFieldDB = fieldDB field , emFieldEmbed = case fieldReference field of EmbedRef em -> Just $ Right em SelfReference -> Just $ Left SelfEmbed _ -> Nothing } -- | Type for storing the Uniqueness constraint in the Schema. Assume you have -- the following schema with a uniqueness constraint: -- -- @ -- Person -- name String -- age Int -- UniqueAge age -- @ -- -- This will be represented as: -- -- @ -- UniqueDef -- { uniqueHaskell = ConstraintNameHS (packPTH "UniqueAge") -- , uniqueDBName = ConstraintNameDB (packPTH "unique_age") -- , uniqueFields = [(FieldNameHS (packPTH "age"), FieldNameDB (packPTH "age"))] -- , uniqueAttrs = [] -- } -- @ -- data UniqueDef = UniqueDef { uniqueHaskell :: !ConstraintNameHS , uniqueDBName :: !ConstraintNameDB , uniqueFields :: !(NonEmpty (FieldNameHS, FieldNameDB)) , uniqueAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord, Lift) data CompositeDef = CompositeDef { compositeFields :: !(NonEmpty FieldDef) , compositeAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord, Lift) -- | Used instead of FieldDef -- to generate a smaller amount of code type ForeignFieldDef = (FieldNameHS, FieldNameDB) data ForeignDef = ForeignDef { foreignRefTableHaskell :: !EntityNameHS , foreignRefTableDBName :: !EntityNameDB , foreignConstraintNameHaskell :: !ConstraintNameHS , foreignConstraintNameDBName :: !ConstraintNameDB , foreignFieldCascade :: !FieldCascade -- ^ Determine how the field will cascade on updates and deletions. -- -- @since 2.11.0 , foreignFields :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity , foreignAttrs :: ![Attr] , foreignNullable :: Bool , foreignToPrimary :: Bool -- ^ Determines if the reference is towards a Primary Key or not. -- -- @since 2.11.0 } deriving (Show, Eq, Read, Ord, Lift) -- | This datatype describes how a foreign reference field cascades deletes -- or updates. -- -- This type is used in both parsing the model definitions and performing -- migrations. A 'Nothing' in either of the field values means that the -- user has not specified a 'CascadeAction'. An unspecified 'CascadeAction' -- is defaulted to 'Restrict' when doing migrations. -- -- @since 2.11.0 data FieldCascade = FieldCascade { fcOnUpdate :: !(Maybe CascadeAction) , fcOnDelete :: !(Maybe CascadeAction) } deriving (Show, Eq, Read, Ord, Lift) -- | A 'FieldCascade' that does nothing. -- -- @since 2.11.0 noCascade :: FieldCascade noCascade = FieldCascade Nothing Nothing -- | Renders a 'FieldCascade' value such that it can be used in SQL -- migrations. -- -- @since 2.11.0 renderFieldCascade :: FieldCascade -> Text renderFieldCascade (FieldCascade onUpdate onDelete) = T.unwords [ foldMap (mappend " ON DELETE " . renderCascadeAction) onDelete , foldMap (mappend " ON UPDATE " . renderCascadeAction) onUpdate ] -- | An action that might happen on a deletion or update on a foreign key -- change. -- -- @since 2.11.0 data CascadeAction = Cascade | Restrict | SetNull | SetDefault deriving (Show, Eq, Read, Ord, Lift) -- | Render a 'CascadeAction' to 'Text' such that it can be used in a SQL -- command. -- -- @since 2.11.0 renderCascadeAction :: CascadeAction -> Text renderCascadeAction action = case action of Cascade -> "CASCADE" Restrict -> "RESTRICT" SetNull -> "SET NULL" SetDefault -> "SET DEFAULT" data PersistException = PersistError Text -- ^ Generic Exception | 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 deriving (Show, Read, Eq, Ord, Lift) data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn | BackendSpecificFilter T.Text deriving (Read, Show, Lift) data UpdateException = KeyNotFound String | UpsertError String instance Show UpdateException where show (KeyNotFound key) = "Key not found during updateGet: " ++ key show (UpsertError msg) = "Error during upsert: " ++ msg instance Exception UpdateException data OnlyUniqueException = OnlyUniqueException String instance Show OnlyUniqueException where show (OnlyUniqueException uniqueMsg) = "Expected only one unique key, got " ++ uniqueMsg instance Exception OnlyUniqueException data PersistUpdate = Assign | Add | Subtract | Multiply | Divide | BackendSpecificUpdate T.Text deriving (Read, Show, Lift) -- | A 'FieldDef' represents the inormation that @persistent@ knows about -- a field of a datatype. This includes information used to parse the field -- out of the database and what the field corresponds to. data FieldDef = FieldDef { fieldHaskell :: !FieldNameHS -- ^ The name of the field. Note that this does not corresponds to the -- record labels generated for the particular entity - record labels -- are generated with the type name prefixed to the field, so -- a 'FieldDef' that contains a @'FieldNameHS' "name"@ for a type -- @User@ will have a record field @userName@. , fieldDB :: !FieldNameDB -- ^ The name of the field in the database. For SQL databases, this -- corresponds to the column name. , fieldType :: !FieldType -- ^ The type of the field in Haskell. , fieldSqlType :: !SqlType -- ^ The type of the field in a SQL database. , fieldAttrs :: ![FieldAttr] -- ^ User annotations for a field. These are provided with the @!@ -- operator. , fieldStrict :: !Bool -- ^ If this is 'True', then the Haskell datatype will have a strict -- record field. The default value for this is 'True'. , fieldReference :: !ReferenceDef , fieldCascade :: !FieldCascade -- ^ Defines how operations on the field cascade on to the referenced -- tables. This doesn't have any meaning if the 'fieldReference' is set -- to 'NoReference' or 'SelfReference'. The cascade option here should -- be the same as the one obtained in the 'fieldReference'. -- -- @since 2.11.0 , fieldComments :: !(Maybe Text) -- ^ Optional comments for a 'Field'. -- -- @since 2.10.0 , fieldGenerated :: !(Maybe Text) -- ^ Whether or not the field is a @GENERATED@ column, and additionally -- the expression to use for generation. -- -- @since 2.11.0.0 , fieldIsImplicitIdColumn :: !Bool -- ^ 'True' if the field is an implicit ID column. 'False' otherwise. -- -- @since 2.13.0.0 } deriving (Show, Eq, Read, Ord, Lift) persistent-2.14.6.0/Database/Persist/Sql/Internal.hs0000644000000000000000000001647614476403105020356 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns , defaultAttribute , BackendSpecificOverrides(..) , getBackendSpecificForeignKeyName , setBackendSpecificForeignKeyName , emptyBackendSpecificOverrides ) where import Control.Applicative ((<|>)) import Data.Monoid (mappend, mconcat) import Data.Text (Text) import qualified Data.Text as T import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Database.Persist.EntityDef import Database.Persist.Sql.Types import Database.Persist.Types -- | Record of functions to override the default behavior in 'mkColumns'. It is -- recommended you initialize this with 'emptyBackendSpecificOverrides' and -- override the default values, so that as new fields are added, your code still -- compiles. -- -- For added safety, use the @getBackendSpecific*@ and @setBackendSpecific*@ -- functions, as a breaking change to the record field labels won't be reflected -- in a major version bump of the library. -- -- @since 2.11 data BackendSpecificOverrides = BackendSpecificOverrides { backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) } -- | If the override is defined, then this returns a function that accepts an -- entity name and field name and provides the 'ConstraintNameDB' for the -- foreign key constraint. -- -- An abstract accessor for the 'BackendSpecificOverrides' -- -- @since 2.13.0.0 getBackendSpecificForeignKeyName :: BackendSpecificOverrides -> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) getBackendSpecificForeignKeyName = backendSpecificForeignKeyName -- | Set the backend's foreign key generation function to this value. -- -- @since 2.13.0.0 setBackendSpecificForeignKeyName :: (EntityNameDB -> FieldNameDB -> ConstraintNameDB) -> BackendSpecificOverrides -> BackendSpecificOverrides setBackendSpecificForeignKeyName func bso = bso { backendSpecificForeignKeyName = Just func } findMaybe :: (a -> Maybe b) -> [a] -> Maybe b findMaybe p = listToMaybe . mapMaybe p -- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides) -- -- @since 2.11 emptyBackendSpecificOverrides :: BackendSpecificOverrides emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing defaultAttribute :: [FieldAttr] -> Maybe Text defaultAttribute = findMaybe $ \case FieldAttrDefault x -> Just x _ -> Nothing -- | Create the list of columns for the given entity. mkColumns :: [EntityDef] -> EntityDef -> BackendSpecificOverrides -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t overrides = (cols, getEntityUniquesNoPrimaryKey t, getEntityForeignDefs t) where cols :: [Column] cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t) idCol :: [FieldDef] idCol = case getEntityId t of EntityIdNaturalKey _ -> [] EntityIdField fd -> [fd] goId :: FieldDef -> Column goId fd = Column { cName = fieldDB fd , cNull = False , cSqlType = fieldSqlType fd , cDefault = case defaultAttribute $ fieldAttrs fd of Nothing -> -- So this is not necessarily a problem... -- because you can use eg `inserKey` to insert -- a value into the database without ever asking -- for a default attribute. Nothing -- But we need to be able to say "Hey, if this is -- an *auto generated ID column*, then I need to -- specify that it has the default serial picking -- behavior for whatever SQL backend this is using. -- Because naturally MySQL, Postgres, MSSQL, etc -- all do ths differently, sigh. -- Really, this should be something like, -- -- > data ColumnDefault -- > = Custom Text -- > | AutogenerateId -- > | NoDefault -- -- where Autogenerated is determined by the -- MkPersistSettings. Just def -> Just def , cGenerated = fieldGenerated fd , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd , cReference = mkColumnReference fd } tableName :: EntityNameDB tableName = getEntityDBName t go :: FieldDef -> Column go fd = Column { cName = fieldDB fd , cNull = case isFieldNullable fd of Nullable _ -> True NotNullable -> isFieldMaybe fd || isEntitySum t , cSqlType = fieldSqlType fd , cDefault = defaultAttribute $ fieldAttrs fd , cGenerated = fieldGenerated fd , cDefaultConstraintName = Nothing , cMaxLen = maxLen $ fieldAttrs fd , cReference = mkColumnReference fd } maxLen :: [FieldAttr] -> Maybe Integer maxLen = findMaybe $ \case FieldAttrMaxlen n -> Just n _ -> Nothing refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides) mkColumnReference :: FieldDef -> Maybe ColumnReference mkColumnReference fd = fmap (\(tName, cName) -> ColumnReference tName cName $ overrideNothings $ fieldCascade fd ) $ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd) -- a 'Nothing' in the definition means that the QQ migration doesn't -- specify behavior. the default is RESTRICT. setting this here -- explicitly makes migrations run smoother. overrideNothings (FieldCascade { fcOnUpdate = upd, fcOnDelete = del }) = FieldCascade { fcOnUpdate = upd <|> Just Restrict , fcOnDelete = del <|> Just Restrict } ref :: FieldNameDB -> ReferenceDef -> [FieldAttr] -> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name ref c fe [] | ForeignRef f <- fe = Just (resolveTableName allDefs f, refNameFn tableName c) | otherwise = Nothing ref _ _ (FieldAttrNoreference:_) = Nothing ref c fe (a:as) = case a of FieldAttrReference x -> do (_, constraintName) <- ref c fe as pure (EntityNameDB x, constraintName) FieldAttrConstraint x -> do (tableName_, _) <- ref c fe as pure (tableName_, ConstraintNameDB x) _ -> ref c fe as refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB refName (EntityNameDB table) (FieldNameDB column) = ConstraintNameDB $ Data.Monoid.mconcat [table, "_", column, "_fkey"] resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t resolveTableName (e:es) hn | getEntityHaskellName e == hn = getEntityDBName e | otherwise = resolveTableName es hn persistent-2.14.6.0/Database/Persist/Sql/Types.hs0000644000000000000000000001131614476403105017672 0ustar0000000000000000module 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(..) ) where import Control.Exception (Exception(..)) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Resource (ResourceT) import Data.Pool (Pool) import Data.Text (Text) import Data.Time (NominalDiffTime) import Database.Persist.Sql.Types.Internal import Database.Persist.Types data Column = Column { cName :: !FieldNameDB , cNull :: !Bool , cSqlType :: !SqlType , cDefault :: !(Maybe Text) , cGenerated :: !(Maybe Text) , cDefaultConstraintName :: !(Maybe ConstraintNameDB) , cMaxLen :: !(Maybe Integer) , cReference :: !(Maybe ColumnReference) } deriving (Eq, Ord, Show) -- | This value specifies how a field references another table. -- -- @since 2.11.0.0 data ColumnReference = ColumnReference { crTableName :: !EntityNameDB -- ^ The table name that the -- -- @since 2.11.0.0 , crConstraintName :: !ConstraintNameDB -- ^ The name of the foreign key constraint. -- -- @since 2.11.0.0 , crFieldCascade :: !FieldCascade -- ^ Whether or not updates/deletions to the referenced table cascade -- to this table. -- -- @since 2.11.0.0 } deriving (Eq, Ord, Show) data PersistentSqlException = StatementAlreadyFinalized Text | Couldn'tGetSQLConnection deriving Show instance Exception PersistentSqlException type SqlPersistT = ReaderT SqlBackend type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO)) type ConnectionPool = Pool SqlBackend -- | Values to configure a pool of database connections. See "Data.Pool" for details. -- -- @since 2.11.0.0 data ConnectionPoolConfig = ConnectionPoolConfig { connectionPoolConfigStripes :: Int -- ^ How many stripes to divide the pool into. See "Data.Pool" for details. Default: 1. , connectionPoolConfigIdleTimeout :: NominalDiffTime -- ^ How long connections can remain idle before being disposed of, in seconds. Default: 600 , connectionPoolConfigSize :: Int -- ^ How many connections should be held in the connection pool. Default: 10 } deriving (Show) -- TODO: Bad defaults for SQLite maybe? -- | Initializes a ConnectionPoolConfig with default values. See the documentation of 'ConnectionPoolConfig' for each field's default value. -- -- @since 2.11.0.0 defaultConnectionPoolConfig :: ConnectionPoolConfig defaultConnectionPoolConfig = ConnectionPoolConfig 1 600 10 -- $rawSql -- -- Although it covers most of the useful cases, @persistent@'s -- API may not be enough for some of your tasks. May be you need -- some complex @JOIN@ query, or a database-specific command -- needs to be issued. -- -- To issue raw SQL queries, use 'rawSql'. It does all the hard work of -- automatically parsing the rows of the result. It may return: -- -- * An 'Entity', that which 'selectList' returns. -- All of your entity's fields are -- automatically parsed. -- -- * A @'Single' a@, which is a single, raw column of type @a@. -- You may use a Haskell type (such as in your entity -- definitions), for example @Single Text@ or @Single Int@, -- or you may get the raw column value with @Single -- 'PersistValue'@. -- -- * A tuple combining any of these (including other tuples). -- Using tuples allows you to return many entities in one -- query. -- -- The only difference between issuing SQL queries with 'rawSql' -- and using other means is that we have an /entity selection/ -- /placeholder/, the double question mark @??@. It /must/ be -- used whenever you want to @SELECT@ an 'Entity' from your -- query. Here's a sample SQL query @sampleStmt@ that may be -- issued: -- -- @ -- SELECT ??, ?? -- FROM \"Person\", \"Likes\", \"Object\" -- WHERE \"Person\".id = \"Likes\".\"personId\" -- AND \"Object\".id = \"Likes\".\"objectId\" -- AND \"Person\".name LIKE ? -- @ -- -- To use that query, you could say -- -- @ -- do results <- 'rawSql' sampleStmt [\"%Luke%\"] -- forM_ results $ -- \\( Entity personKey person -- , Entity objectKey object -- ) -> do ... -- @ -- -- 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) persistent-2.14.6.0/Database/Persist/Sql/Raw.hs0000644000000000000000000002371314476403105017323 0ustar0000000000000000module Database.Persist.Sql.Raw where import Control.Exception (throwIO) import Control.Monad (liftM, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (logDebugNS, runLoggingT) import Control.Monad.Reader (MonadReader, ReaderT, ask) import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, mkAcquire, with) import Data.Conduit import Data.IORef (newIORef, readIORef, writeIORef) import Data.Int (Int64) import Data.Text (Text, pack) import qualified Data.Text as T import Database.Persist import Database.Persist.Sql.Class import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal import Database.Persist.SqlBackend.Internal.StatementCache rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text -> [PersistValue] -> ConduitM () [PersistValue] m () rawQuery sql vals = do srcRes <- liftPersist $ rawQueryRes sql vals (releaseKey, src) <- allocateAcquire srcRes src release releaseKey rawQueryRes :: (MonadIO m1, MonadIO m2, BackendCompatible SqlBackend env) => Text -> [PersistValue] -> 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) (connLogFunc conn) getStmtConn conn sql return $ do stmt <- mkAcquire make stmtReset 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 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 sql vals = do conn <- projectBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt return res getStmt :: (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 mstmt <- statementCacheLookup (connStmtMap conn) cacheK stmt <- case mstmt of Just stmt -> pure stmt Nothing -> do stmt' <- liftIO $ connPrepare conn sql iactive <- liftIO $ newIORef True let stmt = Statement { stmtFinalize = do active <- readIORef iactive when active $ do stmtFinalize stmt' writeIORef iactive False , stmtReset = do active <- readIORef iactive when active $ stmtReset stmt' , stmtExecute = \x -> do active <- readIORef iactive if active then stmtExecute stmt' x else throwIO $ StatementAlreadyFinalized sql , stmtQuery = \x -> do active <- liftIO $ readIORef iactive if active then stmtQuery stmt' x else liftIO $ throwIO $ StatementAlreadyFinalized sql } liftIO $ statementCacheInsert (connStmtMap conn) cacheK stmt pure stmt (hookGetStatement $ connHooks conn) conn sql stmt -- | Execute a raw SQL statement and return its results as a -- list. If you do not expect a return value, use of -- `rawExecute` is recommended. -- -- If you're using 'Entity'@s@ (which is quite likely), then you -- /must/ use entity selection placeholders (double question -- mark, @??@). These @??@ placeholders are then replaced for -- the names of the columns that we need for your entities. -- You'll receive an error if you don't use the placeholders. -- Please see the 'Entity'@s@ documentation for more details. -- -- You may put value placeholders (question marks, @?@) in your -- SQL query. These placeholders are then replaced by the values -- you pass on the second parameter, already correctly escaped. -- You may want to use 'toPersistValue' to help you constructing -- the placeholder values. -- -- Since you're giving a raw SQL statement, you don't get any -- guarantees regarding safety. If 'rawSql' is not able to parse -- the results of your query back, then an exception is raised. -- However, most common problems are mitigated by using the -- entity selection placeholder @??@, and you shouldn't see any -- error at all if you're not using 'Single'. -- -- Some example of 'rawSql' based on this schema: -- -- @ -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- Person -- name String -- age Int Maybe -- deriving Show -- BlogPost -- title String -- authorId PersonId -- deriving Show -- |] -- @ -- -- Examples based on the above schema: -- -- @ -- getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person] -- getPerson = rawSql "select ?? from person where name=?" [PersistText "john"] -- -- getAge :: MonadIO m => ReaderT SqlBackend m [Single Int] -- getAge = rawSql "select person.age from person where name=?" [PersistText "john"] -- -- getAgeName :: MonadIO m => ReaderT SqlBackend m [(Single Int, Single Text)] -- getAgeName = rawSql "select person.age, person.name from person where name=?" [PersistText "john"] -- -- getPersonBlog :: MonadIO m => ReaderT SqlBackend m [(Entity Person, Entity BlogPost)] -- getPersonBlog = rawSql "select ??,?? from person,blog_post where person.id = blog_post.author_id" [] -- @ -- -- Minimal working program for PostgreSQL backend based on the above concepts: -- -- > {-# LANGUAGE EmptyDataDecls #-} -- > {-# LANGUAGE FlexibleContexts #-} -- > {-# LANGUAGE GADTs #-} -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- > {-# LANGUAGE MultiParamTypeClasses #-} -- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE QuasiQuotes #-} -- > {-# LANGUAGE TemplateHaskell #-} -- > {-# LANGUAGE TypeFamilies #-} -- > -- > import Control.Monad.IO.Class (liftIO) -- > import Control.Monad.Logger (runStderrLoggingT) -- > import Database.Persist -- > import Control.Monad.Reader -- > import Data.Text -- > import Database.Persist.Sql -- > import Database.Persist.Postgresql -- > import Database.Persist.TH -- > -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > Person -- > name String -- > age Int Maybe -- > deriving Show -- > |] -- > -- > conn = "host=localhost dbname=new_db user=postgres password=postgres port=5432" -- > -- > getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person] -- > getPerson = rawSql "select ?? from person where name=?" [PersistText "sibi"] -- > -- > liftSqlPersistMPool y x = liftIO (runSqlPersistMPool y x) -- > -- > main :: IO () -- > main = runStderrLoggingT $ withPostgresqlPool conn 10 $ liftSqlPersistMPool $ do -- > runMigration migrateAll -- > 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 stmt = run where getType :: (x -> m [a]) -> a getType = error "rawSql.getType" x = getType run process = rawSqlProcessRow 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 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 conn <- projectBackend `liftM` ask let (colCount, colSubsts) = rawSqlCols (connEscapeRawName conn) x withStmt' colSubsts params $ firstRow colCount 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, ")." ] 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:)) persistent-2.14.6.0/Database/Persist/Sql/Run.hs0000644000000000000000000003131214476403105017330 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Database.Persist.Sql.Run where 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.Pool as P import qualified Data.Text as T import qualified UnliftIO.Exception as UE import Database.Persist.Class.PersistStore 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 -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. -- -- This function performs the given action in a transaction. If an -- exception occurs during the action, then the transaction is rolled back. -- -- Note: This function previously timed out after 2 seconds, but this behavior -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. runSqlPool :: 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 -- | Like 'runSqlPool', but supports specifying an isolation level. -- -- @since 2.9.0 runSqlPoolWithIsolation :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> IsolationLevel -> m a runSqlPoolWithIsolation r pconn i = rawRunSqlPool r pconn (Just i) -- | Like 'runSqlPool', but does not surround the action in a transaction. -- This action might leave your database in a weird state. -- -- @since 2.12.0.0 runSqlPoolNoTransaction :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a runSqlPoolNoTransaction r pconn i = runSqlPoolWithHooks r pconn i (\_ -> pure ()) (\_ -> pure ()) (\_ _ -> pure ()) rawRunSqlPool :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> m a rawRunSqlPool r pconn mi = runSqlPoolWithHooks r pconn mi before after onException where before conn = do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend liftIO $ connBegin sqlBackend getter mi after conn = do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend liftIO $ connCommit sqlBackend getter onException conn _ = do let sqlBackend = projectBackend conn let getter = getStmtConn sqlBackend liftIO $ connRollback sqlBackend getter -- | This function is how 'runSqlPool' and 'runSqlPoolNoTransaction' are -- defined. In addition to the action to be performed and the 'Pool' of -- conections to use, we give you the opportunity to provide three actions -- - initialize, afterwards, and onException. -- -- @since 2.12.0.0 runSqlPoolWithHooks :: forall backend m a before after onException. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> (backend -> m before) -- ^ Run this action immediately before the action is performed. -> (backend -> m after) -- ^ Run this action immediately after the action is completed. -> (backend -> UE.SomeException -> m onException) -- ^ This action is performed when an exception is received. The -- exception is provided as a convenience - it is rethrown once this -- cleanup function is complete. -> m a runSqlPoolWithHooks r pconn i before after onException = runSqlPoolWithExtensibleHooks r pconn i $ SqlPoolHooks { alterBackend = pure , runBefore = \conn _ -> void $ before conn , runAfter = \conn _ -> void $ after conn , runOnException = \b _ e -> void $ onException b e } -- | This function is how 'runSqlPoolWithHooks' is defined. -- -- It's currently the most general function for using a SQL pool. -- -- @since 2.13.0.0 runSqlPoolWithExtensibleHooks :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) => ReaderT backend m a -> Pool backend -> Maybe IsolationLevel -> SqlPoolHooks m backend -> m a runSqlPoolWithExtensibleHooks r pconn i SqlPoolHooks{..} = withRunInIO $ \runInIO -> withResource pconn $ \conn -> 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 . (MonadReader backend m, BackendCompatible SqlBackend backend) => Maybe IsolationLevel -> m (Acquire backend) rawAcquireSqlConn isolation = do conn <- MonadReader.ask let rawConn :: SqlBackend rawConn = projectBackend conn getter :: T.Text -> IO Statement getter = getStmtConn rawConn beginTransaction :: IO backend beginTransaction = conn <$ connBegin rawConn getter isolation finishTransaction :: backend -> ReleaseType -> IO () finishTransaction _ relType = case relType of ReleaseException -> do connRollback rawConn getter _ -> connCommit rawConn getter return $ mkAcquireType beginTransaction finishTransaction -- | Starts a new transaction on the connection. When the acquired connection -- is released the transaction is committed and the connection returned to the -- pool. -- -- Upon an exception the transaction is rolled back and the connection -- destroyed. -- -- This is equivalent to 'runSqlConn' but does not incur the 'MonadUnliftIO' -- constraint, meaning it can be used within, for example, a 'Conduit' -- pipeline. -- -- @since 2.10.5 acquireSqlConn :: (MonadReader backend m, BackendCompatible SqlBackend backend) => m (Acquire backend) acquireSqlConn = rawAcquireSqlConn Nothing -- | Like 'acquireSqlConn', but lets you specify an explicit isolation level. -- -- @since 2.10.5 acquireSqlConnWithIsolation :: (MonadReader backend m, BackendCompatible SqlBackend backend) => 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 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 r conn isolation = with (acquireSqlConnWithIsolation isolation conn) $ runReaderT r runSqlPersistM :: (BackendCompatible SqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn runSqlPersistMPool :: (BackendCompatible SqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool liftSqlPersistMPool :: 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 -> (Pool backend -> m a) -> m a withSqlPool mkConn connCount f = withSqlPoolWithConfig mkConn (defaultConnectionPoolConfig { connectionPoolConfigSize = connCount } ) f -- | Creates a pool of connections to a SQL database which can be used by the @Pool backend -> m a@ function. -- After the function completes, the connections are destroyed. -- -- @since 2.11.0.0 withSqlPoolWithConfig :: forall backend m a. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -- ^ Function to create a new connection -> ConnectionPoolConfig -> (Pool backend -> m a) -> m a withSqlPoolWithConfig mkConn poolConfig f = withUnliftIO $ \u -> UE.bracket (unliftIO u $ createSqlPoolWithConfig mkConn poolConfig) destroyAllResources (unliftIO u . f) createSqlPool :: forall backend m. (MonadLoggerIO m, MonadUnliftIO m, BackendCompatible SqlBackend backend) => (LogFunc -> IO backend) -> Int -> m (Pool backend) 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 -> ConnectionPoolConfig -> m (Pool backend) createSqlPoolWithConfig mkConn config = do logFunc <- askLoggerIO -- Resource pool will swallow any exceptions from close. We want to log -- them instead. let loggedClose :: backend -> IO () loggedClose backend = close' backend `UE.catchAny` \e -> do runLoggingT (logError $ T.pack $ "Error closing database connection in pool: " ++ show e) logFunc UE.throwIO e liftIO $ createPool (mkConn logFunc) loggedClose (connectionPoolConfigStripes config) (connectionPoolConfigIdleTimeout config) (connectionPoolConfigSize config) -- | Create a connection and run sql queries within it. This function -- automatically closes the connection on it's completion. -- -- === __Example usage__ -- -- > {-# LANGUAGE GADTs #-} -- > {-# LANGUAGE ScopedTypeVariables #-} -- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE MultiParamTypeClasses #-} -- > {-# LANGUAGE TypeFamilies#-} -- > {-# LANGUAGE TemplateHaskell#-} -- > {-# LANGUAGE QuasiQuotes#-} -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- > -- > import Control.Monad.IO.Class (liftIO) -- > import Control.Monad.Logger -- > import Conduit -- > import Database.Persist -- > import Database.Sqlite -- > import Database.Persist.Sqlite -- > import Database.Persist.TH -- > -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > Person -- > name String -- > age Int Maybe -- > deriving Show -- > |] -- > -- > openConnection :: LogFunc -> IO SqlBackend -- > openConnection logfn = do -- > conn <- open "/home/sibi/test.db" -- > wrapConnection conn logfn -- > -- > main :: IO () -- > main = do -- > runNoLoggingT $ runResourceT $ withSqlConn openConnection (\backend -> -- > flip runSqlConn backend $ do -- > runMigration migrateAll -- > insert_ $ Person "John doe" $ Just 35 -- > insert_ $ Person "Divya" $ Just 36 -- > (pers :: [Entity Person]) <- selectList [] [] -- > liftIO $ print pers -- > return () -- > ) -- -- On executing it, you get this output: -- -- > 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) => (LogFunc -> IO backend) -> (backend -> m a) -> m a withSqlConn open f = do logFunc <- askLoggerIO withRunInIO $ \run -> UE.bracket (open logFunc) close' (run . f) close' :: (BackendCompatible SqlBackend backend) => backend -> IO () close' conn = do let backend = projectBackend conn statementCacheClear $ connStmtMap backend connClose backend persistent-2.14.6.0/Database/Persist/Sql/Class.hs0000644000000000000000000031257414476403105017645 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..) , EntityWithPrefix(..) , unPrefix ) where import Data.Bits (bitSizeMaybe) import Data.ByteString (ByteString) import Data.Fixed import Data.Foldable (toList) import Data.Int import qualified Data.IntMap as IM import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(..)) import qualified Data.Set as S import Data.Text (Text, intercalate, pack) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Time (Day, TimeOfDay, UTCTime) import qualified Data.Vector as V import Data.Word import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Text.Blaze.Html (Html) import Database.Persist import Database.Persist.Sql.Types -- | Class for data types that may be retrived from a 'rawSql' -- query. class RawSql a where -- | Number of columns that this data type needs and the list -- of substitutions for @SELECT@ placeholders @??@. rawSqlCols :: (Text -> Text) -> a -> (Int, [Text]) -- | A string telling the user why the column count is what -- it is. rawSqlColCountReason :: a -> String -- | Transform a row of the result into the data type. rawSqlProcessRow :: [PersistValue] -> Either Text a instance PersistField a => RawSql (Single a) where rawSqlCols _ _ = (1, []) rawSqlColCountReason _ = "one column for a 'Single' data type" rawSqlProcessRow [pv] = Single <$> fromPersistValue pv rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." instance (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) => RawSql (Key a) where rawSqlCols _ key = (length $ keyToValues key, []) rawSqlColCountReason key = "The primary key is composed of " ++ (show $ length $ keyToValues key) ++ " columns" rawSqlProcessRow = keyFromValues instance (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) => RawSql (Entity record) where rawSqlCols escape _ent = (length sqlFields, [intercalate ", " $ toList sqlFields]) where sqlFields = fmap (((name <> ".") <>) . escapeWith escape) $ fmap fieldDB $ keyAndEntityFields entDef name = escapeWith escape (getEntityDBName entDef) entDef = entityDef (Nothing :: Maybe record) rawSqlColCountReason a = case fst (rawSqlCols (error "RawSql") a) of 1 -> "one column for an 'Entity' data type without fields" n -> show n <> " columns for an 'Entity' data type" rawSqlProcessRow row = case keyFromRecordM of Just mkKey -> do val <- fromPersistValues row pure Entity { entityKey = mkKey val , entityVal = val } Nothing -> case row of (k : rest) -> Entity <$> keyFromValues [k] <*> fromPersistValues rest [] -> Left "Row was empty" -- | This newtype wrapper is useful when selecting an entity out of the -- database and you want to provide a prefix to the table being selected. -- -- Consider this raw SQL query: -- -- > SELECT ?? -- > FROM my_long_table_name AS mltn -- > INNER JOIN other_table AS ot -- > ON mltn.some_col = ot.other_col -- > WHERE ... -- -- We don't want to refer to @my_long_table_name@ every time, so we create -- an alias. If we want to select it, we have to tell the raw SQL -- quasi-quoter that we expect the entity to be prefixed with some other -- name. -- -- We can give the above query a type with this, like: -- -- @ -- getStuff :: 'SqlPersistM' ['EntityWithPrefix' \"mltn\" MyLongTableName] -- getStuff = rawSql queryText [] -- @ -- -- The 'EntityWithPrefix' bit is a boilerplate newtype wrapper, so you can -- remove it with 'unPrefix', like this: -- -- @ -- getStuff :: 'SqlPersistM' ['Entity' MyLongTableName] -- getStuff = 'unPrefix' @\"mltn\" '<$>' 'rawSql' queryText [] -- @ -- -- The @ symbol is a "type application" and requires the @TypeApplications@ -- language extension. -- -- @since 2.10.5 newtype EntityWithPrefix (prefix :: Symbol) record = EntityWithPrefix { unEntityWithPrefix :: Entity record } -- | A helper function to tell GHC what the 'EntityWithPrefix' prefix -- should be. This allows you to use a type application to specify the -- prefix, instead of specifying the etype on the result. -- -- As an example, here's code that uses this: -- -- @ -- myQuery :: 'SqlPersistM' ['Entity' Person] -- myQuery = fmap (unPrefix @\"p\") <$> rawSql query [] -- where -- query = "SELECT ?? FROM person AS p" -- @ -- -- @since 2.10.5 unPrefix :: forall prefix record. EntityWithPrefix prefix record -> Entity record unPrefix = unEntityWithPrefix instance ( PersistEntity record , KnownSymbol prefix , PersistEntityBackend record ~ backend , IsPersistBackend backend ) => RawSql (EntityWithPrefix prefix record) where rawSqlCols escape _ent = (length sqlFields, [intercalate ", " $ toList sqlFields]) where sqlFields = fmap (((name <> ".") <>) . escapeWith escape) $ fmap fieldDB -- Hacky for a composite key because -- it selects the same field multiple times $ keyAndEntityFields entDef name = pack $ symbolVal (Proxy :: Proxy prefix) entDef = entityDef (Nothing :: Maybe record) rawSqlColCountReason a = case fst (rawSqlCols (error "RawSql") a) of 1 -> "one column for an 'Entity' data type without fields" n -> show n ++ " columns for an 'Entity' data type" rawSqlProcessRow row = case splitAt nKeyFields row of (rowKey, rowVal) -> fmap EntityWithPrefix $ Entity <$> keyFromValues rowKey <*> fromPersistValues rowVal where nKeyFields = length $ getEntityKeyFields entDef entDef = entityDef (Nothing :: Maybe record) -- | @since 1.0.1 instance RawSql a => RawSql (Maybe a) where rawSqlCols e = rawSqlCols e . extractMaybe rawSqlColCountReason = rawSqlColCountReason . extractMaybe rawSqlProcessRow cols | all isNull cols = return Nothing | otherwise = case rawSqlProcessRow cols of Right v -> Right (Just v) Left msg -> Left $ "RawSql (Maybe a): not all columns were Null " <> "but the inner parser has failed. Its message " <> "was \"" <> msg <> "\". Did you apply Maybe " <> "to a tuple, perhaps? The main use case for " <> "Maybe is to allow OUTER JOINs to be written, " <> "in which case 'Maybe (Entity v)' is used." where isNull PersistNull = True isNull _ = False instance (RawSql a, RawSql b) => RawSql (a, b) where rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x) where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta ++ lstb) rawSqlColCountReason x = rawSqlColCountReason (fst x) ++ ", " ++ rawSqlColCountReason (snd x) rawSqlProcessRow = let x = getType processRow getType :: (z -> Either y x) -> x getType = error "RawSql.getType" colCountFst = fst $ rawSqlCols (error "RawSql.getType2") (fst x) processRow row = let (rowFst, rowSnd) = splitAt colCountFst row in (,) <$> rawSqlProcessRow rowFst <*> rawSqlProcessRow rowSnd in colCountFst `seq` processRow -- Avoids recalculating 'colCountFst'. instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where rawSqlCols e = rawSqlCols e . from3 rawSqlColCountReason = rawSqlColCountReason . from3 rawSqlProcessRow = fmap to3 . rawSqlProcessRow from3 :: (a,b,c) -> ((a,b),c) from3 (a,b,c) = ((a,b),c) to3 :: ((a,b),c) -> (a,b,c) to3 ((a,b),c) = (a,b,c) instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where rawSqlCols e = rawSqlCols e . from4 rawSqlColCountReason = rawSqlColCountReason . from4 rawSqlProcessRow = fmap to4 . rawSqlProcessRow from4 :: (a,b,c,d) -> ((a,b),(c,d)) from4 (a,b,c,d) = ((a,b),(c,d)) to4 :: ((a,b),(c,d)) -> (a,b,c,d) to4 ((a,b),(c,d)) = (a,b,c,d) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e) => RawSql (a, b, c, d, e) where rawSqlCols e = rawSqlCols e . from5 rawSqlColCountReason = rawSqlColCountReason . from5 rawSqlProcessRow = fmap to5 . rawSqlProcessRow from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e) from5 (a,b,c,d,e) = ((a,b),(c,d),e) to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) to5 ((a,b),(c,d),e) = (a,b,c,d,e) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f) => RawSql (a, b, c, d, e, f) where rawSqlCols e = rawSqlCols e . from6 rawSqlColCountReason = rawSqlColCountReason . from6 rawSqlProcessRow = fmap to6 . rawSqlProcessRow from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f)) from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f)) to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g) => RawSql (a, b, c, d, e, f, g) where rawSqlCols e = rawSqlCols e . from7 rawSqlColCountReason = rawSqlColCountReason . from7 rawSqlProcessRow = fmap to7 . rawSqlProcessRow from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g) from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g) to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h) => RawSql (a, b, c, d, e, f, g, h) where rawSqlCols e = rawSqlCols e . from8 rawSqlColCountReason = rawSqlColCountReason . from8 rawSqlProcessRow = fmap to8 . rawSqlProcessRow from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h)) from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h)) to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) -- | @since 2.10.2 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i) => RawSql (a, b, c, d, e, f, g, h, i) where rawSqlCols e = rawSqlCols e . from9 rawSqlColCountReason = rawSqlColCountReason . from9 rawSqlProcessRow = fmap to9 . rawSqlProcessRow -- | @since 2.10.2 from9 :: (a,b,c,d,e,f,g,h,i) -> ((a,b),(c,d),(e,f),(g,h),i) from9 (a,b,c,d,e,f,g,h,i) = ((a,b),(c,d),(e,f),(g,h),i) -- | @since 2.10.2 to9 :: ((a,b),(c,d),(e,f),(g,h),i) -> (a,b,c,d,e,f,g,h,i) to9 ((a,b),(c,d),(e,f),(g,h),i) = (a,b,c,d,e,f,g,h,i) -- | @since 2.10.2 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j) => RawSql (a, b, c, d, e, f, g, h, i, j) where rawSqlCols e = rawSqlCols e . from10 rawSqlColCountReason = rawSqlColCountReason . from10 rawSqlProcessRow = fmap to10 . rawSqlProcessRow -- | @since 2.10.2 from10 :: (a,b,c,d,e,f,g,h,i,j) -> ((a,b),(c,d),(e,f),(g,h),(i,j)) from10 (a,b,c,d,e,f,g,h,i,j) = ((a,b),(c,d),(e,f),(g,h),(i,j)) -- | @since 2.10.2 to10 :: ((a,b),(c,d),(e,f),(g,h),(i,j)) -> (a,b,c,d,e,f,g,h,i,j) to10 ((a,b),(c,d),(e,f),(g,h),(i,j)) = (a,b,c,d,e,f,g,h,i,j) -- | @since 2.10.2 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k) => RawSql (a, b, c, d, e, f, g, h, i, j, k) where rawSqlCols e = rawSqlCols e . from11 rawSqlColCountReason = rawSqlColCountReason . from11 rawSqlProcessRow = fmap to11 . rawSqlProcessRow -- | @since 2.10.2 from11 :: (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b),(c,d),(e,f),(g,h),(i,j),k) from11 (a,b,c,d,e,f,g,h,i,j,k) = ((a,b),(c,d),(e,f),(g,h),(i,j),k) -- | @since 2.10.2 to11 :: ((a,b),(c,d),(e,f),(g,h),(i,j),k) -> (a,b,c,d,e,f,g,h,i,j,k) to11 ((a,b),(c,d),(e,f),(g,h),(i,j),k) = (a,b,c,d,e,f,g,h,i,j,k) -- | @since 2.10.2 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l) where rawSqlCols e = rawSqlCols e . from12 rawSqlColCountReason = rawSqlColCountReason . from12 rawSqlProcessRow = fmap to12 . rawSqlProcessRow -- | @since 2.10.2 from12 :: (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) from12 (a,b,c,d,e,f,g,h,i,j,k,l) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -- | @since 2.10.2 to12 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l) to12 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l)) = (a,b,c,d,e,f,g,h,i,j,k,l) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m) where rawSqlCols e = rawSqlCols e . from13 rawSqlColCountReason = rawSqlColCountReason . from13 rawSqlProcessRow = fmap to13 . rawSqlProcessRow -- | @since 2.11.0 from13 :: (a,b,c,d,e,f,g,h,i,j,k,l,m) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) from13 (a,b,c,d,e,f,g,h,i,j,k,l,m) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -- | @since 2.11.0 to13 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) -> (a,b,c,d,e,f,g,h,i,j,k,l,m) to13 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),m) = (a,b,c,d,e,f,g,h,i,j,k,l,m) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where rawSqlCols e = rawSqlCols e . from14 rawSqlColCountReason = rawSqlColCountReason . from14 rawSqlProcessRow = fmap to14 . rawSqlProcessRow -- | @since 2.11.0 from14 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) from14 (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -- | @since 2.11.0 to14 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n) to14 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where rawSqlCols e = rawSqlCols e . from15 rawSqlColCountReason = rawSqlColCountReason . from15 rawSqlProcessRow = fmap to15 . rawSqlProcessRow -- | @since 2.11.0 from15 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) from15 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -- | @since 2.11.0 to15 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) to15 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),o) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where rawSqlCols e = rawSqlCols e . from16 rawSqlColCountReason = rawSqlColCountReason . from16 rawSqlProcessRow = fmap to16 . rawSqlProcessRow -- | @since 2.11.0 from16 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) from16 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -- | @since 2.11.0 to16 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) to16 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) where rawSqlCols e = rawSqlCols e . from17 rawSqlColCountReason = rawSqlColCountReason . from17 rawSqlProcessRow = fmap to17 . rawSqlProcessRow -- | @since 2.11.0 from17 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),q) from17 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),q) -- | @since 2.11.0 to17 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),q) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) to17 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),q) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) where rawSqlCols e = rawSqlCols e . from18 rawSqlColCountReason = rawSqlColCountReason . from18 rawSqlProcessRow = fmap to18 . rawSqlProcessRow -- | @since 2.11.0 from18 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r)) from18 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r)) -- | @since 2.11.0 to18 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) to18 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) where rawSqlCols e = rawSqlCols e . from19 rawSqlColCountReason = rawSqlColCountReason . from19 rawSqlProcessRow = fmap to19 . rawSqlProcessRow -- | @since 2.11.0 from19 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),s) from19 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),s) -- | @since 2.11.0 to19 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),s) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) to19 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),s) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) where rawSqlCols e = rawSqlCols e . from20 rawSqlColCountReason = rawSqlColCountReason . from20 rawSqlProcessRow = fmap to20 . rawSqlProcessRow -- | @since 2.11.0 from20 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t)) from20 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t)) -- | @since 2.11.0 to20 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) to20 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) where rawSqlCols e = rawSqlCols e . from21 rawSqlColCountReason = rawSqlColCountReason . from21 rawSqlProcessRow = fmap to21 . rawSqlProcessRow -- | @since 2.11.0 from21 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),u) from21 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),u) -- | @since 2.11.0 to21 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),u) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) to21 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),u) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) where rawSqlCols e = rawSqlCols e . from22 rawSqlColCountReason = rawSqlColCountReason . from22 rawSqlProcessRow = fmap to22 . rawSqlProcessRow -- | @since 2.11.0 from22 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v)) from22 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v)) -- | @since 2.11.0 to22 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) to22 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) where rawSqlCols e = rawSqlCols e . from23 rawSqlColCountReason = rawSqlColCountReason . from23 rawSqlProcessRow = fmap to23 . rawSqlProcessRow -- | @since 2.11.0 from23 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),w) from23 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),w) -- | @since 2.11.0 to23 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),w) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) to23 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),w) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) where rawSqlCols e = rawSqlCols e . from24 rawSqlColCountReason = rawSqlColCountReason . from24 rawSqlProcessRow = fmap to24 . rawSqlProcessRow -- | @since 2.11.0 from24 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x)) from24 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x)) -- | @since 2.11.0 to24 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) to24 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) where rawSqlCols e = rawSqlCols e . from25 rawSqlColCountReason = rawSqlColCountReason . from25 rawSqlProcessRow = fmap to25 . rawSqlProcessRow -- | @since 2.11.0 from25 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),y) from25 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),y) -- | @since 2.11.0 to25 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),y) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) to25 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),y) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) where rawSqlCols e = rawSqlCols e . from26 rawSqlColCountReason = rawSqlColCountReason . from26 rawSqlProcessRow = fmap to26 . rawSqlProcessRow -- | @since 2.11.0 from26 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z)) from26 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z)) -- | @since 2.11.0 to26 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) to26 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2) where rawSqlCols e = rawSqlCols e . from27 rawSqlColCountReason = rawSqlColCountReason . from27 rawSqlProcessRow = fmap to27 . rawSqlProcessRow -- | @since 2.11.0 from27 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),a2) from27 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),a2) -- | @since 2.11.0 to27 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),a2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2) to27 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),a2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2) where rawSqlCols e = rawSqlCols e . from28 rawSqlColCountReason = rawSqlColCountReason . from28 rawSqlProcessRow = fmap to28 . rawSqlProcessRow -- | @since 2.11.0 from28 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2)) from28 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2)) -- | @since 2.11.0 to28 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2) to28 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2) where rawSqlCols e = rawSqlCols e . from29 rawSqlColCountReason = rawSqlColCountReason . from29 rawSqlProcessRow = fmap to29 . rawSqlProcessRow -- | @since 2.11.0 from29 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),c2) from29 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),c2) -- | @since 2.11.0 to29 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),c2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2) to29 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),c2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2) where rawSqlCols e = rawSqlCols e . from30 rawSqlColCountReason = rawSqlColCountReason . from30 rawSqlProcessRow = fmap to30 . rawSqlProcessRow -- | @since 2.11.0 from30 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2)) from30 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2)) -- | @since 2.11.0 to30 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2) to30 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2) where rawSqlCols e = rawSqlCols e . from31 rawSqlColCountReason = rawSqlColCountReason . from31 rawSqlProcessRow = fmap to31 . rawSqlProcessRow -- | @since 2.11.0 from31 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),e2) from31 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),e2) -- | @since 2.11.0 to31 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),e2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2) to31 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),e2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2) where rawSqlCols e = rawSqlCols e . from32 rawSqlColCountReason = rawSqlColCountReason . from32 rawSqlProcessRow = fmap to32 . rawSqlProcessRow -- | @since 2.11.0 from32 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2)) from32 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2)) -- | @since 2.11.0 to32 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2) to32 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2) where rawSqlCols e = rawSqlCols e . from33 rawSqlColCountReason = rawSqlColCountReason . from33 rawSqlProcessRow = fmap to33 . rawSqlProcessRow -- | @since 2.11.0 from33 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),g2) from33 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),g2) -- | @since 2.11.0 to33 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),g2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2) to33 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),g2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2) where rawSqlCols e = rawSqlCols e . from34 rawSqlColCountReason = rawSqlColCountReason . from34 rawSqlProcessRow = fmap to34 . rawSqlProcessRow -- | @since 2.11.0 from34 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2)) from34 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2)) -- | @since 2.11.0 to34 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2) to34 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2) where rawSqlCols e = rawSqlCols e . from35 rawSqlColCountReason = rawSqlColCountReason . from35 rawSqlProcessRow = fmap to35 . rawSqlProcessRow -- | @since 2.11.0 from35 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),i2) from35 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),i2) -- | @since 2.11.0 to35 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),i2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2) to35 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),i2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) where rawSqlCols e = rawSqlCols e . from36 rawSqlColCountReason = rawSqlColCountReason . from36 rawSqlProcessRow = fmap to36 . rawSqlProcessRow -- | @since 2.11.0 from36 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2)) from36 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2)) -- | @since 2.11.0 to36 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) to36 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2) where rawSqlCols e = rawSqlCols e . from37 rawSqlColCountReason = rawSqlColCountReason . from37 rawSqlProcessRow = fmap to37 . rawSqlProcessRow -- | @since 2.11.0 from37 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),k2) from37 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),k2) -- | @since 2.11.0 to37 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),k2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) to37 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),k2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2) where rawSqlCols e = rawSqlCols e . from38 rawSqlColCountReason = rawSqlColCountReason . from38 rawSqlProcessRow = fmap to38 . rawSqlProcessRow -- | @since 2.11.0 from38 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2)) from38 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2)) -- | @since 2.11.0 to38 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) to38 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2) where rawSqlCols e = rawSqlCols e . from39 rawSqlColCountReason = rawSqlColCountReason . from39 rawSqlProcessRow = fmap to39 . rawSqlProcessRow -- | @since 2.11.0 from39 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),m2) from39 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),m2) -- | @since 2.11.0 to39 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),m2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) to39 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),m2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2) where rawSqlCols e = rawSqlCols e . from40 rawSqlColCountReason = rawSqlColCountReason . from40 rawSqlProcessRow = fmap to40 . rawSqlProcessRow -- | @since 2.11.0 from40 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2)) from40 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2)) -- | @since 2.11.0 to40 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) to40 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2) where rawSqlCols e = rawSqlCols e . from41 rawSqlColCountReason = rawSqlColCountReason . from41 rawSqlProcessRow = fmap to41 . rawSqlProcessRow -- | @since 2.11.0 from41 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),o2) from41 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),o2) -- | @since 2.11.0 to41 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),o2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) to41 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),o2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) where rawSqlCols e = rawSqlCols e . from42 rawSqlColCountReason = rawSqlColCountReason . from42 rawSqlProcessRow = fmap to42 . rawSqlProcessRow -- | @since 2.11.0 from42 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2)) from42 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2)) -- | @since 2.11.0 to42 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2) to42 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2) where rawSqlCols e = rawSqlCols e . from43 rawSqlColCountReason = rawSqlColCountReason . from43 rawSqlProcessRow = fmap to43 . rawSqlProcessRow -- | @since 2.11.0 from43 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),q2) from43 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),q2) -- | @since 2.11.0 to43 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),q2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2) to43 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),q2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2) where rawSqlCols e = rawSqlCols e . from44 rawSqlColCountReason = rawSqlColCountReason . from44 rawSqlProcessRow = fmap to44 . rawSqlProcessRow -- | @since 2.11.0 from44 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2)) from44 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2)) -- | @since 2.11.0 to44 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2) to44 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2) where rawSqlCols e = rawSqlCols e . from45 rawSqlColCountReason = rawSqlColCountReason . from45 rawSqlProcessRow = fmap to45 . rawSqlProcessRow -- | @since 2.11.0 from45 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),s2) from45 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),s2) -- | @since 2.11.0 to45 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),s2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2) to45 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),s2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2) where rawSqlCols e = rawSqlCols e . from46 rawSqlColCountReason = rawSqlColCountReason . from46 rawSqlProcessRow = fmap to46 . rawSqlProcessRow -- | @since 2.11.0 from46 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2)) from46 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2)) -- | @since 2.11.0 to46 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2) to46 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2) where rawSqlCols e = rawSqlCols e . from47 rawSqlColCountReason = rawSqlColCountReason . from47 rawSqlProcessRow = fmap to47 . rawSqlProcessRow -- | @since 2.11.0 from47 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),u2) from47 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),u2) -- | @since 2.11.0 to47 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),u2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2) to47 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),u2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2) where rawSqlCols e = rawSqlCols e . from48 rawSqlColCountReason = rawSqlColCountReason . from48 rawSqlProcessRow = fmap to48 . rawSqlProcessRow -- | @since 2.11.0 from48 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2)) from48 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2)) -- | @since 2.11.0 to48 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2) to48 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2) where rawSqlCols e = rawSqlCols e . from49 rawSqlColCountReason = rawSqlColCountReason . from49 rawSqlProcessRow = fmap to49 . rawSqlProcessRow -- | @since 2.11.0 from49 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),w2) from49 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),w2) -- | @since 2.11.0 to49 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),w2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2) to49 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),w2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2) where rawSqlCols e = rawSqlCols e . from50 rawSqlColCountReason = rawSqlColCountReason . from50 rawSqlProcessRow = fmap to50 . rawSqlProcessRow -- | @since 2.11.0 from50 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2)) from50 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2)) -- | @since 2.11.0 to50 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2) to50 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2) where rawSqlCols e = rawSqlCols e . from51 rawSqlColCountReason = rawSqlColCountReason . from51 rawSqlProcessRow = fmap to51 . rawSqlProcessRow -- | @since 2.11.0 from51 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),y2) from51 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),y2) -- | @since 2.11.0 to51 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),y2) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2) to51 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),y2) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2) where rawSqlCols e = rawSqlCols e . from52 rawSqlColCountReason = rawSqlColCountReason . from52 rawSqlProcessRow = fmap to52 . rawSqlProcessRow -- | @since 2.11.0 from52 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2)) from52 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2)) -- | @since 2.11.0 to52 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2) to52 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3) where rawSqlCols e = rawSqlCols e . from53 rawSqlColCountReason = rawSqlColCountReason . from53 rawSqlProcessRow = fmap to53 . rawSqlProcessRow -- | @since 2.11.0 from53 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),a3) from53 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),a3) -- | @since 2.11.0 to53 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),a3) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3) to53 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),a3) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3) where rawSqlCols e = rawSqlCols e . from54 rawSqlColCountReason = rawSqlColCountReason . from54 rawSqlProcessRow = fmap to54 . rawSqlProcessRow -- | @since 2.11.0 from54 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3)) from54 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3)) -- | @since 2.11.0 to54 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3) to54 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3) where rawSqlCols e = rawSqlCols e . from55 rawSqlColCountReason = rawSqlColCountReason . from55 rawSqlProcessRow = fmap to55 . rawSqlProcessRow -- | @since 2.11.0 from55 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),c3) from55 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),c3) -- | @since 2.11.0 to55 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),c3) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3) to55 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),c3) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3) where rawSqlCols e = rawSqlCols e . from56 rawSqlColCountReason = rawSqlColCountReason . from56 rawSqlProcessRow = fmap to56 . rawSqlProcessRow -- | @since 2.11.0 from56 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3)) from56 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3)) -- | @since 2.11.0 to56 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3) to56 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3, RawSql e3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3, e3) where rawSqlCols e = rawSqlCols e . from57 rawSqlColCountReason = rawSqlColCountReason . from57 rawSqlProcessRow = fmap to57 . rawSqlProcessRow -- | @since 2.11.0 from57 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),e3) from57 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),e3) -- | @since 2.11.0 to57 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),e3) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3) to57 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),e3) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3, RawSql e3, RawSql f3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3, e3, f3) where rawSqlCols e = rawSqlCols e . from58 rawSqlColCountReason = rawSqlColCountReason . from58 rawSqlProcessRow = fmap to58 . rawSqlProcessRow -- | @since 2.11.0 from58 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3)) from58 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3)) -- | @since 2.11.0 to58 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3) to58 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3, RawSql e3, RawSql f3, RawSql g3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3, e3, f3, g3) where rawSqlCols e = rawSqlCols e . from59 rawSqlColCountReason = rawSqlColCountReason . from59 rawSqlProcessRow = fmap to59 . rawSqlProcessRow -- | @since 2.11.0 from59 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),g3) from59 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),g3) -- | @since 2.11.0 to59 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),g3) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3) to59 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),g3) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3, RawSql e3, RawSql f3, RawSql g3, RawSql h3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3, e3, f3, g3, h3) where rawSqlCols e = rawSqlCols e . from60 rawSqlColCountReason = rawSqlColCountReason . from60 rawSqlProcessRow = fmap to60 . rawSqlProcessRow -- | @since 2.11.0 from60 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3)) from60 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3)) -- | @since 2.11.0 to60 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3) to60 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3, RawSql e3, RawSql f3, RawSql g3, RawSql h3, RawSql i3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3, e3, f3, g3, h3, i3) where rawSqlCols e = rawSqlCols e . from61 rawSqlColCountReason = rawSqlColCountReason . from61 rawSqlProcessRow = fmap to61 . rawSqlProcessRow -- | @since 2.11.0 from61 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),i3) from61 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),i3) -- | @since 2.11.0 to61 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),i3) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3) to61 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),i3) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3) -- | @since 2.11.0 instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h, RawSql i, RawSql j, RawSql k, RawSql l, RawSql m, RawSql n, RawSql o, RawSql p, RawSql q, RawSql r, RawSql s, RawSql t, RawSql u, RawSql v, RawSql w, RawSql x, RawSql y, RawSql z, RawSql a2, RawSql b2, RawSql c2, RawSql d2, RawSql e2, RawSql f2, RawSql g2, RawSql h2, RawSql i2, RawSql j2, RawSql k2, RawSql l2, RawSql m2, RawSql n2, RawSql o2, RawSql p2, RawSql q2, RawSql r2, RawSql s2, RawSql t2, RawSql u2, RawSql v2, RawSql w2, RawSql x2, RawSql y2, RawSql z2, RawSql a3, RawSql b3, RawSql c3, RawSql d3, RawSql e3, RawSql f3, RawSql g3, RawSql h3, RawSql i3, RawSql j3) => RawSql (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2, q2, r2, s2, t2, u2, v2, w2, x2, y2, z2, a3, b3, c3, d3, e3, f3, g3, h3, i3, j3) where rawSqlCols e = rawSqlCols e . from62 rawSqlColCountReason = rawSqlColCountReason . from62 rawSqlProcessRow = fmap to62 . rawSqlProcessRow -- | @since 2.11.0 from62 :: (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3,j3) -> ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),(i3,j3)) from62 (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3,j3) = ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),(i3,j3)) -- | @since 2.11.0 to62 :: ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),(i3,j3)) -> (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3,j3) to62 ((a,b),(c,d),(e,f),(g,h),(i,j),(k,l),(m,n),(o,p),(q,r),(s,t),(u,v),(w,x),(y,z),(a2,b2),(c2,d2),(e2,f2),(g2,h2),(i2,j2),(k2,l2),(m2,n2),(o2,p2),(q2,r2),(s2,t2),(u2,v2),(w2,x2),(y2,z2),(a3,b3),(c3,d3),(e3,f3),(g3,h3),(i3,j3)) = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,a2,b2,c2,d2,e2,f2,g2,h2,i2,j2,k2,l2,m2,n2,o2,p2,q2,r2,s2,t2,u2,v2,w2,x2,y2,z2,a3,b3,c3,d3,e3,f3,g3,h3,i3,j3) extractMaybe :: Maybe a -> a extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe") -- | Tells Persistent what database column type should be used to store a Haskell type. -- -- ==== __Examples__ -- -- ===== Simple Boolean Alternative -- -- @ -- data Switch = On | Off -- deriving (Show, Eq) -- -- instance 'PersistField' Switch where -- 'toPersistValue' s = case s of -- On -> 'PersistBool' True -- Off -> 'PersistBool' False -- 'fromPersistValue' ('PersistBool' b) = if b then 'Right' On else 'Right' Off -- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a Switch: expected PersistBool, received: " <> T.pack (show x) -- -- instance 'PersistFieldSql' Switch where -- 'sqlType' _ = 'SqlBool' -- @ -- -- ===== Non-Standard Database Types -- -- If your database supports non-standard types, such as Postgres' @uuid@, you can use 'SqlOther' to use them: -- -- @ -- import qualified Data.UUID as UUID -- instance 'PersistField' UUID where -- 'toPersistValue' = 'PersistLiteralEncoded' . toASCIIBytes -- 'fromPersistValue' ('PersistLiteralEncoded' uuid) = -- case fromASCIIBytes uuid of -- 'Nothing' -> 'Left' $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid) -- 'Just' uuid' -> 'Right' uuid' -- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistLiteralEncoded, received: "-- > <> T.pack (show x) -- -- instance 'PersistFieldSql' UUID where -- 'sqlType' _ = 'SqlOther' "uuid" -- @ -- -- ===== User Created Database Types -- -- Similarly, some databases support creating custom types, e.g. Postgres' and features. You can use 'SqlOther' to specify a custom type: -- -- > CREATE DOMAIN ssn AS text -- > CHECK ( value ~ '^[0-9]{9}$'); -- -- @ -- instance 'PersistFieldSQL' SSN where -- 'sqlType' _ = 'SqlOther' "ssn" -- @ -- -- > CREATE TYPE rainbow_color AS ENUM ('red', 'orange', 'yellow', 'green', 'blue', 'indigo', 'violet'); -- -- @ -- instance 'PersistFieldSQL' RainbowColor where -- 'sqlType' _ = 'SqlOther' "rainbow_color" -- @ class PersistField a => PersistFieldSql a where sqlType :: Proxy a -> SqlType #ifndef NO_OVERLAP instance {-# OVERLAPPING #-} PersistFieldSql [Char] where sqlType _ = SqlString #endif instance PersistFieldSql ByteString where sqlType _ = SqlBlob instance PersistFieldSql T.Text where sqlType _ = SqlString instance PersistFieldSql TL.Text where sqlType _ = SqlString instance PersistFieldSql Html where sqlType _ = SqlString instance PersistFieldSql Int where sqlType _ | Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32 | otherwise = SqlInt64 instance PersistFieldSql Int8 where sqlType _ = SqlInt32 instance PersistFieldSql Int16 where sqlType _ = SqlInt32 instance PersistFieldSql Int32 where sqlType _ = SqlInt32 instance PersistFieldSql Int64 where sqlType _ = SqlInt64 instance PersistFieldSql Word where sqlType _ = SqlInt64 instance PersistFieldSql Word8 where sqlType _ = SqlInt32 instance PersistFieldSql Word16 where sqlType _ = SqlInt32 instance PersistFieldSql Word32 where sqlType _ = SqlInt64 instance PersistFieldSql Word64 where sqlType _ = SqlInt64 instance PersistFieldSql Double where sqlType _ = SqlReal instance PersistFieldSql Bool where sqlType _ = SqlBool instance PersistFieldSql Day where sqlType _ = SqlDay instance PersistFieldSql TimeOfDay where sqlType _ = SqlTime instance PersistFieldSql UTCTime where sqlType _ = SqlDayTime instance PersistFieldSql a => PersistFieldSql (Maybe a) where sqlType _ = sqlType (Proxy :: Proxy a) instance {-# OVERLAPPABLE #-} PersistFieldSql a => PersistFieldSql [a] where sqlType _ = SqlString instance PersistFieldSql a => PersistFieldSql (V.Vector a) where sqlType _ = SqlString instance (Ord a, PersistFieldSql a) => PersistFieldSql (S.Set a) where sqlType _ = SqlString instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (a,b) where sqlType _ = SqlString instance PersistFieldSql v => PersistFieldSql (IM.IntMap v) where sqlType _ = SqlString instance PersistFieldSql v => PersistFieldSql (M.Map T.Text v) where sqlType _ = SqlString instance PersistFieldSql PersistValue where sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64 instance PersistFieldSql Checkmark where sqlType _ = SqlBool instance (HasResolution a) => PersistFieldSql (Fixed a) where sqlType a = SqlNumeric long prec where prec = round $ (log $ fromIntegral $ resolution n) / (log 10 :: Double) -- FIXME: May lead to problems with big numbers long = prec + 10 -- FIXME: Is this enough ? n = 0 _mn = return n `asTypeOf` a instance PersistFieldSql Rational where sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC -- | This type uses the 'SqlInt64' version, which will exhibit overflow and -- underflow behavior. Additionally, it permits negative values in the -- database, which isn't ideal. -- -- @since 2.11.0 instance PersistFieldSql OverflowNatural where sqlType _ = SqlInt64 -- An embedded Entity instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where sqlType _ = SqlString persistent-2.14.6.0/Database/Persist/Sql/Orphan/PersistQuery.hs0000644000000000000000000005067314507117603022505 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | TODO: delete this module and get it in with SqlBackend.Internal module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount , filterClause , filterClauseHelper , filterClauseWithVals , orderClause , FilterTablePrefix (..) , decorateSQLWithLimitOffset ) where import Control.Exception (throwIO) import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask) import Data.ByteString.Char8 (readInteger) import Data.Conduit import qualified Data.Conduit.List as CL import Data.Foldable (toList) import Data.Int (Int64) import Data.List (find, inits, transpose) import Data.Maybe (isJust) import Data.Monoid (Monoid(..)) import Data.Text (Text) import qualified Data.Text as T import Database.Persist hiding (updateField) import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types.Internal (SqlBackend(..), SqlReadBackend, SqlWriteBackend) import Database.Persist.Sql.Util ( commaSeparated , dbIdColumns , isIdField , keyAndEntityColumnNames , mkUpdateText , parseEntityValues , parseExistsResult , updatePersistValue ) -- orphaned instance for convenience of modularity instance PersistQueryRead SqlBackend where count filts = do conn <- ask let wher = if null filts then "" else filterClause Nothing conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " , connEscapeTableName conn t , wher ] withRawQuery sql (getFiltsValues conn filts) $ do mm <- CL.head case mm of Just [PersistInt64 i] -> return $ fromIntegral i Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle Just [PersistByteString i] -> case readInteger i of -- gb mssql Just (ret,"") -> return $ fromIntegral ret xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]" Nothing -> error $ "count:invalid sql returned nothing sql["++show sql++"]" where t = entityDef $ dummyFromFilts filts exists filts = do conn <- ask let wher = if null filts then "" else filterClause Nothing conn filts let sql = mconcat [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t , wher , ")" ] withRawQuery sql (getFiltsValues conn filts) $ do mm <- CL.head return $ parseExistsResult mm sql "PersistQuery.exists" where t = entityDef $ dummyFromFilts filts selectSourceRes filts opts = do conn <- ask srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts) return $ fmap (.| CL.mapM parse) srcRes where (limit, offset, orders) = limitOffsetOrder opts parse vals = case parseEntityValues t vals of Left s -> liftIO $ throwIO $ PersistMarshalError ("selectSourceRes: " <> s <> ", vals: " <> T.pack (show vals )) Right row -> return row t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" else filterClause Nothing conn filts ord conn = orderClause Nothing conn orders cols = commaSeparated . toList . keyAndEntityColumnNames t sql conn = connLimitOffset conn (limit,offset) $ mconcat [ "SELECT " , cols conn , " FROM " , connEscapeTableName conn t , wher conn , ord conn ] selectKeysRes filts opts = do conn <- ask srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts) return $ fmap (.| CL.mapM parse) srcRes where 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 ] (limit, offset, orders) = limitOffsetOrder opts ord conn = orderClause Nothing conn orders parse xs = do keyvals <- case entityPrimary t of Nothing -> case xs of [PersistInt64 x] -> return [PersistInt64 x] [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> return xs Just pdef -> let pks = map fieldHaskell $ toList $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ getEntityFields t) xs in return keyvals case keyFromValues keyvals of Right k -> return k Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err instance PersistQueryRead SqlReadBackend where count filts = withBaseBackend $ count filts exists filts = withBaseBackend $ exists filts selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts instance PersistQueryRead SqlWriteBackend where count filts = withBaseBackend $ count filts exists filts = withBaseBackend $ exists filts selectSourceRes filts opts = withBaseBackend $ selectSourceRes filts opts selectKeysRes filts opts = withBaseBackend $ selectKeysRes filts opts instance PersistQueryWrite SqlBackend where deleteWhere filts = do _ <- deleteWhereCount filts return () updateWhere filts upds = do _ <- updateWhereCount filts upds return () instance PersistQueryWrite SqlWriteBackend where deleteWhere filts = withBaseBackend $ deleteWhere filts updateWhere filts upds = withBaseBackend $ updateWhere filts upds -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- @since 1.1.5 deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, BackendCompatible SqlBackend backend) => [Filter val] -> ReaderT backend m Int64 deleteWhereCount filts = withCompatibleBackend $ do conn <- ask let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" else filterClause Nothing conn filts sql = mconcat [ "DELETE FROM " , connEscapeTableName conn t , wher ] rawExecuteCount sql $ getFiltsValues conn filts -- | Same as 'updateWhere', but returns the number of rows affected. -- -- @since 1.1.5 updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, BackendCompatible SqlBackend backend) => [Filter val] -> [Update val] -> ReaderT backend m Int64 updateWhereCount _ [] = return 0 updateWhereCount filts upds = withCompatibleBackend $ do conn <- ask 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 rawExecuteCount sql dat where t = entityDef $ dummyFromFilts filts 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 conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo -- | Used when determining how to prefix a column name in a @WHERE@ clause. -- -- @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 prefixByTable :: Maybe FilterTablePrefix -> Text -- ^ Table name -> (Text -> Text) -- ^ Prefixing function prefixByTable tablePrefix tableName = case tablePrefix of Just PrefixTableName -> ((tableName <> ".") <>) Just PrefixExcluded -> (("EXCLUDED.") <>) _ -> id filterClauseHelper :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED -> Bool -- ^ include WHERE -> SqlBackend -> OrNull -> [Filter val] -> (Text, [PersistValue]) filterClauseHelper tablePrefix includeWhere conn orNull filters = (if not (T.null sql) && includeWhere then " WHERE " <> sql else sql, vals) where (sql, vals) = combineAND filters combineAND = combine " AND " combine s fs = (T.intercalate s $ map wrapP a, mconcat b) where (a, b) = unzip $ map go fs wrapP x = T.concat ["(", x, ")"] go (BackendFilter _) = error "BackendFilter not expected" go (FilterAnd []) = ("1=1", []) go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs go (Filter field value pfilter) = let t = entityDef $ dummyFromFilts [Filter field value pfilter] in case (isIdField field, entityPrimary t, allVals) of (True, Just pdef, PersistList ys:_) -> let cfields = toList $ compositeFields pdef in if length cfields /= length ys then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals else case (allVals, pfilter, isCompFilter pfilter) of ([PersistList xs], Eq, _) -> let sqlcl = T.intercalate " and " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") cfields) in (wrapSql sqlcl, xs) ([PersistList xs], Ne, _) -> let sqlcl = T.intercalate " or " (map (\a -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") cfields) in (wrapSql sqlcl, xs) (_, In, _) -> let xxs = transpose (map fromPersistList allVals) sqls=map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip cfields xxs) in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) (_, NotIn, _) -> let xxs = transpose (map fromPersistList allVals) sqls = map (\(a,xs) -> connEscapeFieldName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip cfields xxs) in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) ([PersistList xs], _, True) -> let zs = tail (inits (toList $ compositeFields pdef)) sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs sql2 islast a = connEscapeFieldName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " sqlcl = T.intercalate " or " sql1 in (wrapSql sqlcl, concat (tail (inits xs))) (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals (True, Just pdef, []) -> error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef (True, Just pdef, _) -> error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef _ -> case (isNull, pfilter, length notNullVals) of (True, Eq, _) -> (name <> " IS NULL", []) (True, Ne, _) -> (name <> " IS NOT NULL", []) (False, Ne, _) -> (T.concat [ "(" , name , " IS NULL OR " , name , " <> " , qmarks , ")" ], notNullVals) -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since -- not all databases support those words directly. (_, In, 0) -> ("1=2" <> orNullSuffix, []) (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) (True, In, _) -> (T.concat [ "(" , name , " IS NULL OR " , name , " IN " , qmarks , ")" ], notNullVals) (False, NotIn, 0) -> ("1=1", []) (True, NotIn, 0) -> (name <> " IS NOT NULL", []) (False, NotIn, _) -> (T.concat [ "(" , name , " IS NULL OR " , name , " NOT IN " , qmarks , ")" ], notNullVals) (True, NotIn, _) -> (T.concat [ "(" , name , " IS NOT NULL AND " , name , " NOT IN " , qmarks , ")" ], notNullVals) _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where isCompFilter Lt = True isCompFilter Le = True isCompFilter Gt = True isCompFilter Ge = True isCompFilter _ = False 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 = \case FilterValue a -> [toPersistValue a] FilterValues as -> toPersistValue <$> as UnsafeValue x -> [toPersistValue x] orNullSuffix = case orNull of 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] 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 showSqlFilter Eq = "=" showSqlFilter Ne = "<>" showSqlFilter Gt = ">" showSqlFilter Lt = "<" showSqlFilter Ge = ">=" showSqlFilter Le = "<=" showSqlFilter In = " IN " showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s -- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion -- into a SQL query. -- -- @since 2.12.1.0 filterClause :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion -- into a SQL query, as well as the @['PersistValue']@ to properly fill in the -- @?@ place holders. -- -- @since 2.12.1.0 filterClauseWithVals :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> (Text, [PersistValue]) filterClauseWithVals b c = filterClauseHelper b True c OrNullNo -- | Render a @['SelectOpt' record]@ made up *only* of 'Asc' and 'Desc' constructors -- into a 'Text' value suitable for inclusion into a SQL query. -- -- @since 2.13.2.0 orderClause :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [SelectOpt val] -> Text orderClause includeTable conn orders = if null orders then "" else " ORDER BY " <> T.intercalate "," (map (\case Asc x -> name x Desc x -> name x <> " DESC" _ -> error "orderClause: expected Asc or Desc, not limit or offset") orders) where dummyFromOrder :: [SelectOpt a] -> Maybe a dummyFromOrder _ = Nothing tn = connEscapeTableName conn (entityDef $ dummyFromOrder orders) name :: (PersistEntity record) => EntityField record typ -> Text name x = prefixByTable includeTable tn $ connEscapeFieldName conn (fieldName x) -- | Generates sql for limit and offset for postgres, sqlite and mysql. decorateSQLWithLimitOffset :: Text -> (Int,Int) -> Text -> Text decorateSQLWithLimitOffset nolimit (limit,offset) sql = let lim = case (limit, offset) of (0, 0) -> "" (0, _) -> T.cons ' ' nolimit (_, _) -> " LIMIT " <> T.pack (show limit) off = if offset == 0 then "" else " OFFSET " <> T.pack (show offset) in mconcat [ sql , lim , off ] persistent-2.14.6.0/Database/Persist/Sql/Orphan/PersistStore.hs0000644000000000000000000003740514507117603022472 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore ( withRawQuery , BackendKey(..) , toSqlKey , fromSqlKey , getFieldName , getTableName , tableDBName , fieldDBName ) where import Control.Exception (throwIO) import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask) import Data.Acquire (with) import qualified Data.Aeson as A import Data.ByteString.Char8 (readInteger) import Data.Conduit (ConduitM, runConduit, (.|)) import qualified Data.Conduit.List as CL import qualified Data.Foldable as Foldable import Data.Function (on) import Data.Int (Int64) import Data.List (find, nubBy) import qualified Data.Map as Map import Data.Maybe (isJust) import Data.Text (Text, unpack) import qualified Data.Text as T import Data.Void (Void) import GHC.Generics (Generic) import Web.HttpApiData (FromHttpApiData, ToHttpApiData) import Web.PathPieces (PathPiece) import Database.Persist import Database.Persist.Class () import Database.Persist.Sql.Class (PersistFieldSql) import Database.Persist.Sql.Raw import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal import Database.Persist.Sql.Util ( commaSeparated , dbIdColumns , keyAndEntityColumnNames , mkInsertValues , mkUpdateText , parseEntityValues , updatePersistValue ) withRawQuery :: MonadIO m => Text -> [PersistValue] -> ConduitM [PersistValue] Void IO a -> ReaderT SqlBackend m a withRawQuery sql vals sink = do srcRes <- rawQueryRes sql vals liftIO $ with srcRes (\src -> runConduit $ src .| sink) toSqlKey :: ToBackendKey SqlBackend record => Int64 -> Key record toSqlKey = fromBackendKey . SqlBackendKey fromSqlKey :: ToBackendKey SqlBackend record => Key record -> Int64 fromSqlKey = unSqlBackendKey . toBackendKey whereStmtForKey :: PersistEntity record => SqlBackend -> Key record -> Text whereStmtForKey conn k = T.intercalate " AND " $ Foldable.toList $ fmap (<> "=? ") $ dbIdColumns conn entDef where entDef = entityDef $ dummyFromKey k 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 -- Useful for raw SQL queries -- -- Your backend may provide a more convenient tableName function -- which does not operate in a Monad getTableName :: forall record m backend. ( PersistEntity record , BackendCompatible SqlBackend backend , Monad m ) => record -> ReaderT backend m Text getTableName rec = withCompatibleBackend $ do conn <- ask return $ connEscapeTableName conn (entityDef $ Just rec) -- | useful for a backend to implement tableName by adding escaping tableDBName :: (PersistEntity record) => record -> EntityNameDB tableDBName rec = getEntityDBName $ entityDef (Just rec) -- | get the SQL string for the field that an EntityField represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient fieldName function -- which does not operate in a Monad getFieldName :: forall record typ m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend , BackendCompatible SqlBackend backend , Monad m ) => EntityField record typ -> ReaderT backend m Text getFieldName rec = 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 = fieldDB . persistFieldDef instance PersistCore SqlBackend where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } deriving stock (Show, Read, Eq, Ord, Generic) deriving newtype (Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance PersistCore SqlReadBackend where newtype BackendKey SqlReadBackend = SqlReadBackendKey { unSqlReadBackendKey :: Int64 } deriving stock (Show, Read, Eq, Ord, Generic) deriving newtype (Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance PersistCore SqlWriteBackend where newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 } deriving stock (Show, Read, Eq, Ord, Generic) deriving newtype (Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance BackendCompatible SqlBackend SqlBackend where projectBackend = id instance BackendCompatible SqlBackend SqlReadBackend where projectBackend = unSqlReadBackend instance BackendCompatible SqlBackend SqlWriteBackend where projectBackend = unSqlWriteBackend instance PersistStoreWrite SqlBackend where 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 ] rawExecute sql $ map updatePersistValue upds `mappend` keyToValues k insert_ val = do conn <- ask let vals = mkInsertValues val case connInsertSql conn (entityDef (Just val)) vals of ISRSingle sql -> do withRawQuery sql vals $ do pure () ISRInsertGet sql1 _sql2 -> do rawExecute sql1 vals ISRManyKeys sql _fs -> do rawExecute sql vals insert val = do conn <- ask let esql = connInsertSql conn t vals 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 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 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 -- TODO: figure out something better for MySQL let convert x = case x of [PersistByteString i] -> case readInteger i of -- mssql Just (ret,"") -> [PersistInt64 $ fromIntegral ret] _ -> x _ -> x -- Yes, it's just <|>. Older bases don't have the -- instance for Either. onLeft Left{} x = x onLeft x _ = x case m >>= (\x -> keyFromValues x `onLeft` keyFromValues (convert x)) of Right k -> return k Left err -> throw $ "ISRInsertGet: keyFromValues failed: " `mappend` err 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 Right k -> return k Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e return key where tshow :: Show a => a -> Text tshow = T.pack . show throw = liftIO . throwIO . userError . T.unpack t = entityDef $ Just val vals = mkInsertValues val insertMany [] = return [] insertMany vals = do conn <- ask case connInsertManySql conn of Nothing -> mapM insert vals Just insertManyFn -> 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 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) 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 ] vals = mkInsertValues val `mappend` keyToValues k rawExecute sql vals where go conn x = connEscapeFieldName conn x `T.append` "=?" insertKey k v = insrepHelper "INSERT" [Entity k v] insertEntityMany es' = do conn <- ask let entDef = entityDef $ map entityVal es' let columnNames = keyAndEntityColumnNames entDef conn runChunked (length columnNames) go es' where go = insrepHelper "INSERT" repsert key value = repsertMany [(key, value)] repsertMany [] = return () repsertMany krsDups = do conn <- ask let krs = nubBy ((==) `on` fst) (reverse krsDups) let rs = snd `fmap` krs let ent = entityDef rs let nr = length krs let toVals (k,r) = case entityPrimary ent of Nothing -> keyToValues k <> (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 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 ] instance PersistStoreWrite SqlWriteBackend where insert v = withBaseBackend $ insert v insertMany vs = withBaseBackend $ insertMany vs insertMany_ vs = withBaseBackend $ insertMany_ vs insertEntityMany vs = withBaseBackend $ insertEntityMany vs insertKey k v = withBaseBackend $ insertKey k v repsert k v = withBaseBackend $ repsert k v replace k v = withBaseBackend $ replace k v delete k = withBaseBackend $ delete k update k upds = withBaseBackend $ update k upds repsertMany krs = withBaseBackend $ repsertMany krs instance PersistStoreRead SqlBackend where get k = do mEs <- getMany [k] return $ Map.lookup k mEs -- inspired by Database.Persist.Sql.Orphan.PersistQuery.selectSourceRes 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) Right row -> return row withRawQuery sql (Foldable.foldMap keyToValues ks) $ do es <- CL.mapM parse .| CL.consume return $ Map.fromList $ fmap (\e -> (entityKey e, entityVal e)) es instance PersistStoreRead SqlReadBackend where get k = withBaseBackend $ get k getMany ks = withBaseBackend $ getMany ks instance PersistStoreRead SqlWriteBackend where get k = withBaseBackend $ get k getMany ks = withBaseBackend $ getMany ks dummyFromKey :: Key record -> Maybe record dummyFromKey = Just . recordTypeFromKey recordTypeFromKey :: Key record -> record recordTypeFromKey _ = error "dummyFromKey" 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 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 , ")" ] vals = Foldable.foldMap entityValues es runChunked :: (Monad m) => Int -> ([a] -> ReaderT SqlBackend m ()) -> [a] -> ReaderT SqlBackend m () 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) -- Implement this here to avoid depending on the split package chunksOf :: Int -> [a] -> [[a]] chunksOf _ [] = [] chunksOf size xs = let (chunk, rest) = splitAt size xs in chunk : chunksOf size rest persistent-2.14.6.0/Database/Persist/Sql/Orphan/PersistUnique.hs0000644000000000000000000001274114507117603022640 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} {-# 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) import qualified Data.Conduit.List as CL import Data.Foldable (toList) import Data.Function (on) import Data.List (nubBy) import qualified Data.Text as T import Database.Persist import Database.Persist.Class.PersistUnique (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 ) 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 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 vals = persistUniqueToValues uniq rawExecute sql' vals where t = entityDef $ dummyFromUnique uniq go = toList . fmap snd . persistUniqueToFieldNames go' conn x = connEscapeFieldName conn x `mappend` "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeTableName conn t , " WHERE " , T.intercalate " AND " $ map (go' conn) $ go uniq] putMany [] = return () putMany rsD = do 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 conn <- ask case connPutManySql conn of (Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals rs) Nothing -> defaultPutMany rs instance PersistUniqueWrite SqlWriteBackend where deleteBy uniq = withBaseBackend $ deleteBy uniq upsert rs us = withBaseBackend $ upsert rs us putMany rs = withBaseBackend $ putMany rs instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask let sql = T.concat [ "SELECT " , T.intercalate "," $ toList $ dbColumns conn t , " FROM " , connEscapeTableName conn t , " WHERE " , 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 where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = connEscapeFieldName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = toList . fmap snd . persistUniqueToFieldNames existsBy uniq = do conn <- ask let sql = T.concat [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t , " WHERE " , sqlClause conn , ")" ] uvals = persistUniqueToValues uniq withRawQuery sql uvals $ do mm <- CL.head return $ parseExistsResult mm sql "PersistUnique.existsBy" where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = connEscapeFieldName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = toList . fmap snd . persistUniqueToFieldNames instance PersistUniqueRead SqlReadBackend where getBy uniq = withBaseBackend $ getBy uniq existsBy uniq = withBaseBackend $ existsBy uniq instance PersistUniqueRead SqlWriteBackend where getBy uniq = withBaseBackend $ getBy uniq existsBy uniq = withBaseBackend $ existsBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing persistent-2.14.6.0/Database/Persist/Compatible/Types.hs0000644000000000000000000001744614507117603021224 0ustar0000000000000000{-# OPTIONS_GHC -Wno-unused-top-binds #-} {- You can't export a data family constructor, so there's an "unused" warning -} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.Compatible.Types ( Compatible(..) ) where import Control.Monad.Trans.Reader (withReaderT) import Data.Aeson import Database.Persist.Class import Database.Persist.Sql.Class -- | A newtype wrapper for compatible backends, mainly useful for @DerivingVia@. -- -- When writing a new backend that is 'BackendCompatible' with an existing backend, -- instances for the new backend can be naturally defined in terms of the -- instances for the existing backend. -- -- For example, if you decide to augment the 'SqlBackend' with some additional -- features: -- -- @ -- data BetterSqlBackend = BetterSqlBackend { sqlBackend :: SqlBackend, ... } -- -- instance BackendCompatible SqlBackend BetterSqlBackend where -- projectBackend = sqlBackend -- @ -- -- Then you can use @DerivingVia@ to automatically get instances like: -- -- @ -- deriving via (Compatible SqlBackend BetterSqlBackend) instance PersistStoreRead BetterSqlBackend -- deriving via (Compatible SqlBackend BetterSqlBackend) instance PersistStoreWrite BetterSqlBackend -- ... -- @ -- -- These instances will go through the compatible backend (in this case, 'SqlBackend') -- for all their queries. -- -- These instances require that both backends have the same 'BaseBackend', but -- deriving 'HasPersistBackend' will enforce that for you. -- -- @ -- deriving via (Compatible SqlBackend BetterSqlBackend) instance HasPersistBackend BetterSqlBackend -- @ -- -- @since 2.12 newtype Compatible b s = Compatible { unCompatible :: s } instance (BackendCompatible b s, HasPersistBackend b) => HasPersistBackend (Compatible b s) where type BaseBackend (Compatible b s) = BaseBackend b persistBackend = persistBackend . projectBackend @b @s . unCompatible instance (BackendCompatible b s, PersistCore b) => PersistCore (Compatible b s) where -- | A newtype wrapper around @'BackendKey' b@, mainly useful for @DerivingVia@. -- -- Similarly to @'Compatible' b s@, this data family instance is handy for deriving -- instances for @'BackendKey' s@ by defining them in terms of @'BackendKey' b@. -- -- -- For example, if you decide to augment the 'SqlBackend' with some additional -- features: -- -- @ -- data BetterSqlBackend = BetterSqlBackend { sqlBackend :: SqlBackend, ... } -- -- instance PersistCore BetterSqlBackend where -- newtype BackendKey BetterSqlBackend = BSQLKey { unBSQLKey :: BackendKey (Compatible SqlBackend BetterSqlBackend) } -- @ -- -- Then you can use @DerivingVia@ to automatically get instances like: -- -- @ -- deriving via BackendKey (Compatible SqlBackend BetterSqlBackend) instance Show (BackendKey BetterSqlBackend) -- ... -- @ -- -- These instances will go through the compatible backend's key (in this case, -- @'BackendKey' 'SqlBackend'@) for all their logic. newtype BackendKey (Compatible b s) = CompatibleKey { unCompatibleKey :: BackendKey b } instance (HasPersistBackend b, BackendCompatible b s, PersistStoreRead b) => PersistStoreRead (Compatible b s) where get = withReaderT (projectBackend @b @s . unCompatible) . get getMany = withReaderT (projectBackend @b @s . unCompatible) . getMany instance (HasPersistBackend b, BackendCompatible b s, PersistQueryRead b) => PersistQueryRead (Compatible b s) where selectSourceRes filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectSourceRes filts opts selectFirst filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectFirst filts opts selectKeysRes filts opts = withReaderT (projectBackend @b @s . unCompatible) $ selectKeysRes filts opts count = withReaderT (projectBackend @b @s . unCompatible) . count exists = withReaderT (projectBackend @b @s . unCompatible) . exists instance (HasPersistBackend b, BackendCompatible b s, PersistQueryWrite b) => PersistQueryWrite (Compatible b s) where updateWhere filts updates = withReaderT (projectBackend @b @s . unCompatible) $ updateWhere filts updates deleteWhere = withReaderT (projectBackend @b @s . unCompatible) . deleteWhere instance (HasPersistBackend b, BackendCompatible b s, PersistUniqueRead b) => PersistUniqueRead (Compatible b s) where getBy = withReaderT (projectBackend @b @s . unCompatible) . getBy existsBy = withReaderT (projectBackend @b @s . unCompatible) . existsBy instance (HasPersistBackend b, BackendCompatible b s, PersistStoreWrite b) => PersistStoreWrite (Compatible b s) where insert = withReaderT (projectBackend @b @s . unCompatible) . insert insert_ = withReaderT (projectBackend @b @s . unCompatible) . insert_ insertMany = withReaderT (projectBackend @b @s . unCompatible) . insertMany insertMany_ = withReaderT (projectBackend @b @s . unCompatible) . insertMany_ insertEntityMany = withReaderT (projectBackend @b @s . unCompatible) . insertEntityMany insertKey k = withReaderT (projectBackend @b @s . unCompatible) . insertKey k repsert k = withReaderT (projectBackend @b @s . unCompatible) . repsert k repsertMany = withReaderT (projectBackend @b @s . unCompatible) . repsertMany replace k = withReaderT (projectBackend @b @s . unCompatible) . replace k delete = withReaderT (projectBackend @b @s . unCompatible) . delete update k = withReaderT (projectBackend @b @s . unCompatible) . update k updateGet k = withReaderT (projectBackend @b @s . unCompatible) . updateGet k instance (HasPersistBackend b, BackendCompatible b s, PersistUniqueWrite b) => PersistUniqueWrite (Compatible b s) where deleteBy = withReaderT (projectBackend @b @s . unCompatible) . deleteBy insertUnique = withReaderT (projectBackend @b @s . unCompatible) . insertUnique upsert rec = withReaderT (projectBackend @b @s . unCompatible) . upsert rec upsertBy uniq rec = withReaderT (projectBackend @b @s . unCompatible) . upsertBy uniq rec putMany = withReaderT (projectBackend @b @s . unCompatible) . putMany deriving via (BackendKey b) instance (BackendCompatible b s, Show (BackendKey b)) => Show (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Read (BackendKey b)) => Read (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Eq (BackendKey b)) => Eq (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Ord (BackendKey b)) => Ord (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Num (BackendKey b)) => Num (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Integral (BackendKey b)) => Integral (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, PersistField (BackendKey b)) => PersistField (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Real (BackendKey b)) => Real (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Enum (BackendKey b)) => Enum (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, Bounded (BackendKey b)) => Bounded (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, ToJSON (BackendKey b)) => ToJSON (BackendKey (Compatible b s)) deriving via (BackendKey b) instance (BackendCompatible b s, FromJSON (BackendKey b)) => FromJSON (BackendKey (Compatible b s)) persistent-2.14.6.0/Database/Persist/Compatible/TH.hs0000644000000000000000000001641714476403105020430 0ustar0000000000000000{-# LANGUAGE DerivingVia #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module Database.Persist.Compatible.TH ( makeCompatibleInstances , makeCompatibleKeyInstances ) where import Data.Aeson import Database.Persist.Class import Database.Persist.Sql.Class import Language.Haskell.TH import Database.Persist.Compatible.Types -- | Gives a bunch of useful instance declarations for a backend based on its -- compatibility with another backend, using 'Compatible'. -- -- The argument should be a type of the form @ forall v1 ... vn. Compatible b s @ -- (Quantification is optional, but supported because TH won't let you have -- unbound type variables in a type splice). The instance is produced for @s@ -- based on the instance defined for @b@, which is constrained in the instance -- head to exist. -- -- @v1 ... vn@ are implicitly quantified in the instance, which is derived via -- @'Compatible' b s@. -- -- @since 2.12 makeCompatibleInstances :: Q Type -> Q [Dec] makeCompatibleInstances compatibleType = do (b, s) <- compatibleType >>= \case ForallT _ _ (AppT (AppT (ConT conTName) b) s) -> if conTName == ''Compatible then pure (b, s) else fail $ "Cannot make `deriving via` instances if the argument is " <> "not of the form `forall v1 ... vn. Compatible sub sup`" AppT (AppT (ConT conTName) b) s -> if conTName == ''Compatible then pure (b, s) else fail $ "Cannot make `deriving via` instances if the argument is " <> "not of the form `Compatible sub sup`" _ -> fail $ "Cannot make `deriving via` instances if the argument is " <> "not of the form `Compatible sub sup`" [d| deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b)) => HasPersistBackend $(return s) deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistStoreRead $(return b)) => PersistStoreRead $(return s) deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistQueryRead $(return b)) => PersistQueryRead $(return s) deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistUniqueRead $(return b)) => PersistUniqueRead $(return s) deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistStoreWrite $(return b)) => PersistStoreWrite $(return s) deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistQueryWrite $(return b)) => PersistQueryWrite $(return s) deriving via (Compatible $(return b) $(return s)) instance (HasPersistBackend $(return b), PersistUniqueWrite $(return b)) => PersistUniqueWrite $(return s) |] -- | Gives a bunch of useful instance declarations for a backend key based on -- its compatibility with another backend & key, using 'Compatible'. -- -- The argument should be a type of the form @ forall v1 ... vn. Compatible b s @ -- (Quantification is optional, but supported because TH won't let you have -- unbound type variables in a type splice). The instance is produced for -- @'BackendKey' s@ based on the instance defined for @'BackendKey' b@, which -- is constrained in the instance head to exist. -- -- @v1 ... vn@ are implicitly quantified in the instance, which is derived via -- @'BackendKey' ('Compatible' b s)@. -- -- @since 2.12 makeCompatibleKeyInstances :: Q Type -> Q [Dec] makeCompatibleKeyInstances compatibleType = do (b, s) <- compatibleType >>= \case ForallT _ _ (AppT (AppT (ConT conTName) b) s) -> if conTName == ''Compatible then pure (b, s) else fail $ "Cannot make `deriving via` instances if the argument is " <> "not of the form `forall v1 ... vn. Compatible sub sup`" AppT (AppT (ConT conTName) b) s -> if conTName == ''Compatible then pure (b, s) else fail $ "Cannot make `deriving via` instances if the argument is " <> "not of the form `Compatible sub sup`" _ -> fail $ "Cannot make `deriving via` instances if the argument is " <> "not of the form `Compatible sub sup`" [d| deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Show (BackendKey $(return b))) => Show (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Read (BackendKey $(return b))) => Read (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Eq (BackendKey $(return b))) => Eq (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Ord (BackendKey $(return b))) => Ord (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Num (BackendKey $(return b))) => Num (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Integral (BackendKey $(return b))) => Integral (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), PersistField (BackendKey $(return b))) => PersistField (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), PersistFieldSql (BackendKey $(return b))) => PersistFieldSql (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Real (BackendKey $(return b))) => Real (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Enum (BackendKey $(return b))) => Enum (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), Bounded (BackendKey $(return b))) => Bounded (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), ToJSON (BackendKey $(return b))) => ToJSON (BackendKey $(return s)) deriving via (BackendKey (Compatible $(return b) $(return s))) instance (PersistCore $(return b), PersistCore $(return s), FromJSON (BackendKey $(return b))) => FromJSON (BackendKey $(return s)) |] persistent-2.14.6.0/test/main.hs0000644000000000000000000000070514476403105014575 0ustar0000000000000000module Main where import Test.Hspec import qualified Database.Persist.ClassSpec as ClassSpec import qualified Database.Persist.PersistValueSpec as PersistValueSpec import qualified Database.Persist.QuasiSpec as QuasiSpec import qualified Database.Persist.THSpec as THSpec main :: IO () main = hspec $ do describe "Database" $ describe "Persist" $ do THSpec.spec QuasiSpec.spec ClassSpec.spec PersistValueSpec.spec persistent-2.14.6.0/test/Database/Persist/ClassSpec.hs0000644000000000000000000000077214476403105020672 0ustar0000000000000000module Database.Persist.ClassSpec where import Database.Persist.Class import Data.Time import Database.Persist.Types import Test.Hspec spec :: Spec spec = describe "Class" $ do describe "PersistField" $ do describe "UTCTime" $ do it "fromPersistValue with format" $ fromPersistValue (PersistText "2018-02-27 10:49:42.123") `shouldBe` Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) persistent-2.14.6.0/test/Database/Persist/PersistValueSpec.hs0000644000000000000000000000270614476403105022252 0ustar0000000000000000module Database.Persist.PersistValueSpec where import Test.Hspec import Database.Persist.PersistValue import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.Text as T 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 describe "Aeson" $ do let testPrefix constr prefixChar bytes = takePrefix (toJSON (constr (BS8.pack bytes))) === String (T.singleton prefixChar) roundTrip constr bytes = fromJSON (toJSON (constr (BS8.pack bytes))) === Data.Aeson.Success (constr (BS8.pack bytes)) subject constr prefixChar = do prop ("encodes with a " ++ [prefixChar] ++ " prefix") $ testPrefix constr prefixChar prop "Round Trips" $ roundTrip constr describe "PersistDbSpecific" $ do subject (PersistLiteral_ DbSpecific) 'p' describe "PersistLiteral" $ do subject PersistLiteral 'l' describe "PersistLiteralEscaped" $ do subject PersistLiteralEscaped 'e' takePrefix :: Value -> Value takePrefix (String a) = String (T.take 1 a) takePrefix a = a persistent-2.14.6.0/test/Database/Persist/QuasiSpec.hs0000644000000000000000000014153314507120063020702 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} module Database.Persist.QuasiSpec where 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'] shouldErrorWithMessage :: IO a -> String -> Expectation shouldErrorWithMessage action expectedMsg = do res <- try action case res of Left (ErrorCall msg) -> msg `shouldBe` expectedMsg _ -> expectationFailure "Expected `error` to have been called" persistent-2.14.6.0/test/Database/Persist/TH/CommentSpec.hs0000644000000000000000000000341514507117603021537 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -haddock #-} module Database.Persist.TH.CommentSpec ( CommentModel (..) , spec ) where import TemplateTestImports import Database.Persist.EntityDef.Internal (EntityDef(..)) import Database.Persist.FieldDef.Internal (FieldDef(..)) mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase| -- | Doc comments work. -- | Has multiple lines. CommentModel -- | First line of comment on column. -- | Second line of comment on column. name String deriving Eq Show |] pass :: IO () pass = pure () asIO :: IO a -> IO a asIO = id spec :: Spec spec = describe "CommentSpec" $ do let ed = entityDef (Proxy @CommentModel) it "has entity comments" $ do entityComments ed `shouldBe` do Just $ mconcat [ "Doc comments work.\n" , "Has multiple lines.\n" ] describe "fieldComments" $ do let [nameComments] = map fieldComments $ entityFields ed it "has the right name comments" $ do nameComments `shouldBe` do Just $ mconcat [ "First line of comment on column.\n" , "Second line of comment on column.\n" ] persistent-2.14.6.0/test/Database/Persist/TH/CompositeKeyStyleSpec.hs0000644000000000000000000000361414507117603023572 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} module Database.Persist.TH.CompositeKeyStyleSpec where import Data.Data (Data, constrFields, toConstr) import Data.Text (Text) import Database.Persist.Sql import Database.Persist.TH import Test.Hspec hiding (Selector) mkPersist sqlSettings [persistLowerCase| CompanyUserLegacyStyle companyName Text userName Text Primary companyName userName |] deriving instance Data CompanyUserLegacyStyle deriving instance Data (Key CompanyUserLegacyStyle) mkPersist sqlSettings {mpsCamelCaseCompositeKeySelector = True} [persistLowerCase| CompanyUserCamelStyle companyName Text userName Text Primary companyName userName |] deriving instance Data CompanyUserCamelStyle deriving instance Data (Key CompanyUserCamelStyle) spec :: Spec spec = describe "CompositeKeyStyleSpec" $ do describe "mpsCamelCaseCompositeKeySelector is False" $ do it "Should generate Legacy style key selectors" $ do let key = CompanyUserLegacyStyleKey "cName" "uName" constrFields (toConstr key) `shouldBe` [ "companyUserLegacyStyleKeycompanyName" , "companyUserLegacyStyleKeyuserName" ] describe "mpsCamelCaseCompositeKeySelector is True" $ do it "Should generate CamelCase style key selectors" $ do let key = CompanyUserCamelStyleKey "cName" "uName" constrFields (toConstr key) `shouldBe` [ "companyUserCamelStyleKeyCompanyName" , "companyUserCamelStyleKeyUserName" ] persistent-2.14.6.0/test/Database/Persist/TH/DiscoverEntitiesSpec.hs0000644000000000000000000000240014476403105023411 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.DiscoverEntitiesSpec where import TemplateTestImports import Data.Aeson import Data.Text (Text) import Language.Haskell.TH.Syntax import Database.Persist.ImplicitIdDef import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) mkPersist sqlSettings [persistLowerCase| User name String age Int Dog user UserId name String Cat enemy DogId name String |] pass :: IO () pass = pure () asIO :: IO a -> IO a asIO = id $(pure []) spec :: Spec spec = describe "DiscoverEntitiesSpec" $ do let entities = $(discoverEntities) it "should have all three entities" $ do entities `shouldMatchList` [ entityDef $ Proxy @User , entityDef $ Proxy @Dog , entityDef $ Proxy @Cat ] persistent-2.14.6.0/test/Database/Persist/TH/EmbedSpec.hs0000644000000000000000000001103114476403105021142 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.EmbedSpec where import TemplateTestImports import Data.Text (Text) import qualified Data.Map as M import qualified Data.Text as T 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| Thing name String foo String MigrationOnly deriving Eq Show EmbedThing someThing Thing deriving Eq Show SelfEmbed name Text self SelfEmbed Maybe deriving Eq Show MutualEmbed thing MutualTarget MutualTarget thing [MutualEmbed] ModelWithList names [Text] HasMap map (M.Map T.Text T.Text) deriving Show Eq Read Ord MapIdValue map (M.Map T.Text (Key Thing)) deriving Show Eq Read Ord |] pass :: IO () pass = pure () asIO :: IO a -> IO a asIO = id spec :: Spec spec = describe "EmbedSpec" $ do describe "ModelWithList" $ do let edef = entityDef $ Proxy @ModelWithList [fieldDef] = getEntityFields edef it "has the right type" $ do fieldType fieldDef `shouldBe` FTList (FTTypeCon Nothing "Text") it "has the right sqltype" $ do fieldSqlType fieldDef `shouldBe` SqlString describe "MapIdValue" $ do let edef = entityDef $ Proxy @MapIdValue [fieldDef] = getEntityFields edef it "has the right type" $ do fieldType fieldDef `shouldBe` ( FTTypeCon (Just "M") "Map" `FTApp` FTTypeCon (Just "T") "Text" `FTApp` (FTTypeCon Nothing "Key" `FTApp` FTTypeCon Nothing "Thing" ) ) it "has the right sqltype" $ do fieldSqlType fieldDef `shouldBe` SqlString describe "HasMap" $ do let edef = entityDef $ Proxy @HasMap [fieldDef] = getEntityFields edef it "has the right type" $ do fieldType fieldDef `shouldBe` ( FTTypeCon (Just "M") "Map" `FTApp` FTTypeCon (Just "T") "Text" `FTApp` FTTypeCon (Just "T") "Text" ) it "has the right sqltype" $ do fieldSqlType fieldDef `shouldBe` SqlString describe "SomeThing" $ do let edef = entityDef $ Proxy @Thing describe "toEmbedEntityDef" $ do let embedDef = toEmbedEntityDef edef it "should have the same field count as Haskell fields" $ do length (embeddedFields embedDef) `shouldBe` length (getEntityFields edef) describe "EmbedThing" $ do it "generates the right constructor" $ do let embedThing :: EmbedThing embedThing = EmbedThing (Thing "asdf") pass describe "SelfEmbed" $ do let edef = entityDef $ Proxy @SelfEmbed describe "fieldReference" $ do let [nameField, selfField] = getEntityFields edef it "has self reference" $ do fieldReference selfField `shouldBe` NoReference describe "toEmbedEntityDef" $ do let embedDef = toEmbedEntityDef edef it "has the same field count as regular def" $ do length (getEntityFields edef) `shouldBe` length (embeddedFields embedDef) persistent-2.14.6.0/test/Database/Persist/TH/EntityHaddockSpec.hs0000644000000000000000000000216414507117603022667 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Database.Persist.TH.EntityHaddockSpec (spec) where import TemplateTestImports #if MIN_VERSION_template_haskell(2,18,0) import Database.Persist.TH.CommentSpec (CommentModel (..)) import Language.Haskell.TH (DocLoc (DeclDoc), getDoc) import Language.Haskell.TH.Syntax (lift) [d| commentModelDoc :: Maybe String commentModelDoc = $(lift =<< getDoc (DeclDoc ''CommentModel)) commentFieldDoc :: Maybe String commentFieldDoc = $(lift =<< getDoc (DeclDoc 'commentModelName)) |] spec :: Spec spec = describe "EntityHaddockSpec" $ do it "generates entity Haddock" $ do let expected = unlines [ "Doc comments work." , "Has multiple lines." ] commentModelDoc `shouldBe` Just expected it "generates field Haddock" $ do let expected = unlines [ "First line of comment on column." , "Second line of comment on column." ] commentFieldDoc `shouldBe` Just expected #else spec :: Spec spec = pure () #endif persistent-2.14.6.0/test/Database/Persist/TH/ForeignRefSpec.hs0000644000000000000000000001322514476403105022163 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- -- 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 Data.Aeson import Data.ByteString.Lazy.Char8 () import Data.Coerce import Data.Functor.Identity (Identity(..)) import Data.Int import qualified Data.List as List import Data.Proxy import Data.Text (Text, pack) import GHC.Generics (Generic) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) import Database.Persist import Database.Persist.EntityDef.Internal import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports mkPersist sqlSettings [persistLowerCase| HasCustomName sql=custom_name name Text ForeignTarget name Text deriving Eq Show ForeignSource name Text foreignTargetId ForeignTargetId Foreign ForeignTarget fk_s_t foreignTargetId ForeignPrimary name Text Primary name deriving Eq Show ForeignPrimarySource name Text Foreign ForeignPrimary fk_name_target name NullableRef name Text Maybe Foreign ForeignPrimary fk_nullable_ref name ParentImplicit name Text ChildImplicit name Text parent ParentImplicitId OnDeleteCascade OnUpdateCascade ParentExplicit name Text Primary name ChildExplicit name Text Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name |] spec :: Spec spec = describe "ForeignRefSpec" $ do describe "HasCustomName" $ do let edef = entityDef $ Proxy @HasCustomName it "should have a custom db name" $ do entityDB edef `shouldBe` EntityNameDB "custom_name" it "should compile" $ do True `shouldBe` True describe "ForeignPrimarySource" $ do let fpsDef = entityDef $ Proxy @ForeignPrimarySource [foreignDef] = entityForeigns fpsDef it "has the right type" $ do foreignPrimarySourceFk_name_target (ForeignPrimarySource "asdf") `shouldBe` ForeignPrimaryKey "asdf" describe "Cascade" $ do describe "Explicit" $ do let parentDef = entityDef $ Proxy @ParentExplicit childDef = entityDef $ Proxy @ChildExplicit childForeigns = entityForeigns childDef it "should have a single foreign reference defined" $ do case entityForeigns childDef of [a] -> pure () as -> expectationFailure . mconcat $ [ "Expected one foreign reference on childDef, " , "got: " , show as ] let [ForeignDef {..}] = childForeigns describe "ChildExplicit" $ do it "should have the right target table" $ do foreignRefTableHaskell `shouldBe` EntityNameHS "ParentExplicit" foreignRefTableDBName `shouldBe` EntityNameDB "parent_explicit" it "should have the right cascade behavior" $ do foreignFieldCascade `shouldBe` FieldCascade { fcOnUpdate = Just Cascade , fcOnDelete = Just Cascade } it "is not nullable" $ do foreignNullable `shouldBe` False it "is to the Primary key" $ do foreignToPrimary `shouldBe` True describe "Implicit" $ do let parentDef = entityDef $ Proxy @ParentImplicit childDef = entityDef $ Proxy @ChildImplicit childFields = entityFields childDef describe "ChildImplicit" $ do case childFields of [nameField, parentIdField] -> do it "parentId has reference" $ do fieldReference parentIdField `shouldBe` ForeignRef (EntityNameHS "ParentImplicit") as -> error . mconcat $ [ "Expected one foreign reference on childDef, " , "got: " , show as ] persistent-2.14.6.0/test/Database/Persist/TH/ImplicitIdColSpec.hs0000644000000000000000000000326514476403105022625 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.ImplicitIdColSpec where import TemplateTestImports import Data.Text (Text) import Database.Persist.ImplicitIdDef import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) do let uuidDef = mkImplicitIdDef @Text "uuid_generate_v1mc()" settings = setImplicitIdDef uuidDef sqlSettings mkPersist settings [persistLowerCase| User name String age Int |] pass :: IO () pass = pure () asIO :: IO a -> IO a asIO = id spec :: Spec spec = describe "ImplicitIdColSpec" $ do describe "UserKey" $ do it "has type Text -> Key User" $ do let userKey = UserKey "Hello" _ = UserKey :: Text -> UserId pass describe "getEntityId" $ do let EntityIdField idField = getEntityId (entityDef (Nothing @User)) it "has SqlString SqlType" $ asIO $ do fieldSqlType idField `shouldBe` SqlString it "has Text FieldType" $ asIO $ do pendingWith "currently returns UserId, may not be an issue" fieldType idField `shouldBe` fieldTypeFromTypeable @Text persistent-2.14.6.0/test/Database/Persist/TH/JsonEncodingSpec.hs0000644000000000000000000000755714476403105022530 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.JsonEncodingSpec where import TemplateTestImports import Data.Aeson import Data.Text (Text) import Test.Hspec.QuickCheck import Test.QuickCheck import Test.QuickCheck.Instances () import Database.Persist.EntityDef import Database.Persist.ImplicitIdDef import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) import Database.Persist.Types mkPersist sqlSettings [persistLowerCase| JsonEncoding json name Text age Int Primary name deriving Show Eq JsonEncoding2 json name Text age Int blood Text Primary name blood deriving Show Eq JsonEncMigrationOnly json name Text age Int foo Text MigrationOnly |] instance Arbitrary JsonEncoding where arbitrary = JsonEncoding <$> arbitrary <*> arbitrary instance Arbitrary JsonEncoding2 where arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary pass :: IO () pass = pure () asIO :: IO a -> IO a asIO = id spec :: Spec spec = describe "JsonEncodingSpec" $ do let subject = JsonEncoding "Bob" 32 subjectEntity = Entity (JsonEncodingKey (jsonEncodingName subject)) subject it "encodes without an ID field" $ do toJSON subjectEntity `shouldBe` object [ ("name", String "Bob") , ("age", toJSON (32 :: Int)) , ("id", String "Bob") ] it "decodes without an ID field" $ do let json_ = encode . object $ [ ("name", String "Bob") , ("age", toJSON (32 :: Int)) ] eitherDecode json_ `shouldBe` Right subjectEntity it "has informative decoder errors" $ do let json_ = encode Null (eitherDecode json_ :: Either String JsonEncoding) `shouldBe` Left "Error in $: parsing JsonEncoding failed, expected Object, but encountered Null" prop "works with a Primary" $ \jsonEncoding -> do let ent = Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding decode (encode ent) `shouldBe` Just ent prop "excuse me what" $ \j@JsonEncoding{..} -> do let ent = Entity (JsonEncodingKey jsonEncodingName) j toJSON ent `shouldBe` object [ ("name", toJSON jsonEncodingName) , ("age", toJSON jsonEncodingAge) , ("id", toJSON jsonEncodingName) ] prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do let key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood ent = Entity key j decode (encode ent) `shouldBe` Just ent prop "works with a composite key" $ \j@JsonEncoding2{..} -> do let key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood ent = Entity key j toJSON ent `shouldBe` object [ ("name", toJSON jsonEncoding2Name) , ("age", toJSON jsonEncoding2Age) , ("blood", toJSON jsonEncoding2Blood) , ("id", toJSON key) ] persistent-2.14.6.0/test/Database/Persist/TH/KindEntitiesSpec.hs0000644000000000000000000000211614476403105022524 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.KindEntitiesSpec where import Database.Persist.TH.KindEntitiesSpecImports import TemplateTestImports mkPersist sqlSettings [persistLowerCase| Customer name String age Int CustomerTransfer customerId CustomerId moneyAmount (MoneyAmount 'CustomerOwned 'Debit) |] spec :: Spec spec = describe "KindEntities" $ do it "should support DataKinds in entity definition" $ do let mkTransfer :: CustomerId -> MoneyAmount 'CustomerOwned 'Debit -> CustomerTransfer mkTransfer = CustomerTransfer getAmount :: CustomerTransfer -> MoneyAmount 'CustomerOwned 'Debit getAmount = customerTransferMoneyAmount compiles compiles :: Expectation compiles = True `shouldBe` True persistent-2.14.6.0/test/Database/Persist/TH/KindEntitiesSpecImports.hs0000644000000000000000000000115614476403105024105 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} module Database.Persist.TH.KindEntitiesSpecImports where import Data.Proxy import qualified Data.Text as T import TemplateTestImports data Owner = MerchantOwned | CustomerOwned data AccountKind = Debit | Credit newtype MoneyAmount (a :: Owner) (b :: AccountKind) = MoneyAmount Rational instance PersistFieldSql (MoneyAmount a b) where sqlType _ = sqlType (Proxy :: Proxy Rational) instance PersistField (MoneyAmount a b) where toPersistValue (MoneyAmount n) = toPersistValue n fromPersistValue v = MoneyAmount <$> fromPersistValue v persistent-2.14.6.0/test/Database/Persist/TH/MaybeFieldDefsSpec.hs0000644000000000000000000000145214476403105022737 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.MaybeFieldDefsSpec where import TemplateTestImports mkPersist sqlSettings [persistLowerCase| Account name (Maybe String) email String |] spec :: Spec spec = describe "MaybeFieldDefs" $ do it "should support literal `Maybe` declaration in entity definition" $ do let mkAccount :: Maybe String -> String -> Account mkAccount = Account compiles compiles :: Expectation compiles = True `shouldBe` True persistent-2.14.6.0/test/Database/Persist/TH/MigrationOnlySpec.hs0000644000000000000000000000354414476403105022733 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.MigrationOnlySpec where import TemplateTestImports import Data.Text (Text) import Database.Persist.ImplicitIdDef import Database.Persist.ImplicitIdDef.Internal (fieldTypeFromTypeable) import Database.Persist.Types mkPersist sqlSettings [persistLowerCase| HasMigrationOnly name String blargh Int MigrationOnly deriving Eq Show |] pass :: IO () pass = pure () asIO :: IO a -> IO a asIO = id spec :: Spec spec = describe "MigrationOnlySpec" $ do describe "HasMigrationOnly" $ do let edef = entityDef $ Proxy @HasMigrationOnly describe "getEntityFields" $ do it "has one field" $ do length (getEntityFields edef) `shouldBe` 1 describe "getEntityFieldsDatabase" $ do it "has two fields" $ do length (getEntityFieldsDatabase edef) `shouldBe` 2 describe "toPersistFields" $ do it "should have one field" $ do map toPersistValue (toPersistFields (HasMigrationOnly "asdf")) `shouldBe` [PersistText ("asdf" :: Text)] describe "fromPersistValues" $ do it "should work with only item in list" $ do fromPersistValues [PersistText "Hello"] `shouldBe` Right (HasMigrationOnly "Hello") persistent-2.14.6.0/test/Database/Persist/TH/MultiBlockSpec.hs0000644000000000000000000000407614476403105022206 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.MultiBlockSpec where import TemplateTestImports import Database.Persist.TH.MultiBlockSpec.Model share [ mkPersistWith sqlSettings importDefList ] [persistLowerCase| Thing name Text Primary name ThingAuto name Text MBBar name Text age Int user UserId thing ThingId thingAuto ThingAutoId profile MBDogId Foreign MBCompositePrimary bar_to_comp name age |] spec :: Spec spec = describe "MultiBlockSpec" $ do describe "MBBar" $ do let edef = entityDef $ Proxy @MBBar describe "Foreign Key Works" $ do let [n, a, userRef, thingRef, thingAutoRef, profileRef] = getEntityFields edef it "User reference works" $ do fieldReference userRef `shouldBe` ForeignRef (EntityNameHS "User") it "Primary key reference works" $ do fieldReference profileRef `shouldBe` ForeignRef (EntityNameHS "MBDog") it "Thing ref works (same block)" $ do fieldReference thingRef `shouldBe` ForeignRef (EntityNameHS "Thing") it "ThingAuto ref works (same block)" $ do fieldReference thingAutoRef `shouldBe` ForeignRef (EntityNameHS "ThingAuto") persistent-2.14.6.0/test/Database/Persist/TH/MultiBlockSpec/Model.hs0000644000000000000000000000160414476403105023240 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.MultiBlockSpec.Model where import TemplateTestImports share [ mkPersist sqlSettings , mkEntityDefList "importDefList" ] [persistLowerCase| User name Text age Int deriving Eq Show MBDog name Text Primary name MBCompositePrimary name Text age Int Primary name age |] persistent-2.14.6.0/test/Database/Persist/TH/NestedSymbolsInTypeSpec.hs0000644000000000000000000000301714476403105024057 0ustar0000000000000000{-# OPTIONS_GHC -Wno-unused-local-binds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.NestedSymbolsInTypeSpec where import Data.Map import Database.Persist.TH.NestedSymbolsInTypeSpecImports import TemplateTestImports mkPersist sqlSettings [persistLowerCase| PathEntitySimple readOnly (Maybe (SomePath ReadOnly)) PathEntityNested paths (Maybe (Map Text [SomePath ReadWrite])) |] spec :: Spec spec = describe "NestedSymbolsInType" $ do it "should support nested parens" $ do let mkPathEntitySimple :: Maybe (SomePath ReadOnly) -> PathEntitySimple mkPathEntitySimple = PathEntitySimple pathEntitySimpleReadOnly' :: PathEntitySimple -> Maybe (SomePath ReadOnly) pathEntitySimpleReadOnly' = pathEntitySimpleReadOnly compiles it "should support deeply nested parens + square brackets" $ do let mkPathEntityNested :: Maybe (Map Text [SomePath ReadWrite]) -> PathEntityNested mkPathEntityNested = PathEntityNested pathEntityNestedPaths' :: PathEntityNested -> Maybe (Map Text [SomePath ReadWrite]) pathEntityNestedPaths' = pathEntityNestedPaths compiles compiles :: Expectation compiles = True `shouldBe` True persistent-2.14.6.0/test/Database/Persist/TH/NestedSymbolsInTypeSpecImports.hs0000644000000000000000000000072514476403105025440 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} module Database.Persist.TH.NestedSymbolsInTypeSpecImports where import Data.Proxy import TemplateTestImports data ReadOnly data ReadWrite newtype SomePath a = SomePath Text instance PersistFieldSql (SomePath a) where sqlType _ = SqlString instance PersistField (SomePath a) where toPersistValue (SomePath n) = toPersistValue n fromPersistValue v = SomePath <$> fromPersistValue v persistent-2.14.6.0/test/Database/Persist/TH/NoFieldSelectorsSpec.hs0000644000000000000000000000162314507117603023340 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 902 {-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE DuplicateRecordFields #-} #endif {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} module Database.Persist.TH.NoFieldSelectorsSpec where import TemplateTestImports #if __GLASGOW_HASKELL__ >= 902 mkPersist sqlSettings {mpsFieldLabelModifier = const id} [persistLowerCase| User ident Text name Text Primary ident team TeamId type Text Team name Text |] spec :: Spec spec = it "compiles" True #else spec :: Spec spec = do it "only works with GHC 9.2 or greater" $ do pendingWith "only works with GHC 9.2 or greater" #endif persistent-2.14.6.0/test/Database/Persist/TH/OverloadedLabelSpec.hs0000644000000000000000000000314014507117603023154 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} module Database.Persist.TH.OverloadedLabelSpec where import TemplateTestImports mkPersist sqlSettings [persistUpperCase| User name String age Int Dog userId UserId name String age Int Organization name String Student userId UserId departmentName String Primary userId |] spec :: Spec spec = describe "OverloadedLabels" $ do it "works for monomorphic labels" $ do let UserName = #name OrganizationName = #name DogName = #name compiles it "works for polymorphic labels" $ do let name :: _ => EntityField rec a name = #name UserName = name OrganizationName = name DogName = name compiles it "works for id labels" $ do let UserId = #id orgId = #id :: EntityField Organization OrganizationId compiles it "works for Primary labels" $ do let StudentId = #id studentId = #id :: EntityField Student StudentId compiles compiles :: IO () compiles = pure () persistent-2.14.6.0/test/Database/Persist/TH/PersistWith/Model.hs0000644000000000000000000000133114476403105022642 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.PersistWith.Model where import TemplateTestImports import Database.Persist.TH.PersistWith.Model2 as Model2 mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| IceCream flavor FlavorId otherFlavor Model2.FlavorId |] persistent-2.14.6.0/test/Database/Persist/TH/PersistWith/Model2.hs0000644000000000000000000000114314476403105022725 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.PersistWith.Model2 where import TemplateTestImports mkPersist sqlSettings [persistLowerCase| Flavor name Text |] persistent-2.14.6.0/test/Database/Persist/TH/PersistWithSpec.hs0000644000000000000000000000452514476403105022425 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.PersistWithSpec where import Control.Monad import TemplateTestImports import Database.Persist.TH.PersistWith.Model as Model (IceCream, IceCreamId) import Language.Haskell.TH as TH mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| BestTopping iceCream IceCreamId otherCream Model.IceCreamId keyCream (Key IceCream) qualifiedKeyCream (Key Model.IceCream) nullableCream IceCreamId Maybe maybeCream (Maybe IceCreamId) maybeQualifiedCream (Maybe Model.IceCreamId) maybeQualifiedKeyCream (Maybe (Key Model.IceCream)) maybeKeyCream (Maybe (Key IceCream)) |] deriving instance Show (EntityField BestTopping a) deriving instance Eq (EntityField BestTopping a) data SomeField where SomeField :: EntityField BestTopping a -> SomeField allFields = [ SomeField BestToppingIceCream , SomeField BestToppingOtherCream , SomeField BestToppingKeyCream , SomeField BestToppingQualifiedKeyCream , SomeField BestToppingMaybeCream , SomeField BestToppingNullableCream , SomeField BestToppingMaybeQualifiedCream , SomeField BestToppingMaybeQualifiedKeyCream , SomeField BestToppingMaybeKeyCream ] spec :: Spec spec = describe "mkPersistWith" $ do describe "finds references" $ do forM_ allFields $ \(SomeField field) -> it (show field) (shouldReferToIceCream field) shouldReferToIceCream :: EntityField BestTopping a -> IO () shouldReferToIceCream field = unless (reference == iceCreamRef) $ do expectationFailure $ mconcat [ "The field '", show field, "' does not have a reference to IceCream.\n" , "Got Reference: ", show reference, "\n" , "Expected : ", show iceCreamRef ] where reference = fieldReference (persistFieldDef field) iceCreamRef = ForeignRef (EntityNameHS "IceCream") persistent-2.14.6.0/test/Database/Persist/TH/RequireOnlyPersistImportSpec.hs0000644000000000000000000000237214476403105025161 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.RequireOnlyPersistImportSpec where -- This test asserts this is the only import required to define entities -- See: https://github.com/yesodweb/persistent/pull/1369 import Database.Persist.TH -- always explicitly import qualified Hspec in the context of this spec import qualified Test.Hspec as HS mkPersist sqlSettings [persistLowerCase| Plain name String age Int deriving Show Eq JsonEncoded json name String age Int deriving Show Eq |] spec :: HS.Spec spec = HS.describe "RequireOnlyPersistImport" $ do HS.it "Plain" $ do let typeSigPlain :: String -> Int -> Plain typeSigPlain = Plain compiles HS.it "JsonEncoded" $ do let typeSigJsonEncoded :: String -> Int -> JsonEncoded typeSigJsonEncoded = JsonEncoded compiles compiles :: HS.Expectation compiles = True `HS.shouldBe` True persistent-2.14.6.0/test/Database/Persist/TH/SharedPrimaryKeyImportedSpec.hs0000644000000000000000000000433014476403105025061 0ustar0000000000000000{-# LANGUAGE TypeApplications, DeriveGeneric #-} {-# LANGUAGE DataKinds, ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} module Database.Persist.TH.SharedPrimaryKeyImportedSpec where import TemplateTestImports 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 Database.Persist.TH.SharedPrimaryKeySpec (User, UserId) mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| ProfileX Id UserId email String |] -- This test is very similar to the one in SharedPrimaryKeyTest, but it is -- able to use 'UserId' directly, since the type is imported from another -- module. spec :: Spec spec = describe "Shared Primary Keys Imported" $ do describe "PersistFieldSql" $ do it "should match underlying key" $ do sqlType (Proxy @UserId) `shouldBe` sqlType (Proxy @ProfileXId) describe "getEntityId FieldDef" $ do it "should match underlying primary key" $ do let getSqlType :: PersistEntity a => Proxy a -> SqlType getSqlType p = case getEntityId (entityDef p) of EntityIdField fd -> fieldSqlType fd _ -> SqlOther "Composite Key" getSqlType (Proxy @User) `shouldBe` getSqlType (Proxy @ProfileX) describe "foreign reference should work" $ do it "should have a foreign reference" $ do pendingWith "issue #1289" let Just fd = getEntityIdField (entityDef (Proxy @ProfileX)) fieldReference fd `shouldBe` ForeignRef (EntityNameHS "User") persistent-2.14.6.0/test/Database/Persist/TH/SharedPrimaryKeySpec.hs0000644000000000000000000001057614476403105023366 0ustar0000000000000000{-# LANGUAGE TypeApplications, DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# 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 Database.Persist import Database.Persist.EntityDef import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH share [ mkPersist sqlSettings ] [persistLowerCase| User name String Profile Id UserId email String Profile2 Id (Key User) email String DayKeyTable Id Day name Text RefDayKey dayKey DayKeyTableId |] spec :: Spec spec = describe "Shared Primary Keys" $ do let getSqlType :: PersistEntity a => Proxy a -> SqlType getSqlType p = case getEntityId (entityDef p) of EntityIdField fd -> fieldSqlType fd _ -> SqlOther "Composite Key" keyProxy :: Proxy a -> Proxy (Key a) keyProxy _ = Proxy sqlTypeEquivalent :: (PersistFieldSql (Key a), PersistEntity a) => Proxy a -> Expectation sqlTypeEquivalent proxy = sqlType (keyProxy proxy) `shouldBe` getSqlType proxy testSqlTypeEquivalent :: (PersistFieldSql (Key a), PersistEntity a) => Proxy a -> Spec testSqlTypeEquivalent prxy = it "has equivalent SqlType from sqlType and entityId" $ sqlTypeEquivalent prxy describe "PersistFieldSql" $ do it "should match underlying key" $ do sqlType (Proxy @UserId) `shouldBe` sqlType (Proxy @ProfileId) describe "User" $ do it "has default ID key, SqlInt64" $ do sqlType (Proxy @UserId) `shouldBe` SqlInt64 testSqlTypeEquivalent (Proxy @User) describe "Profile" $ do it "has same ID key type as User" $ do sqlType (Proxy @ProfileId) `shouldBe` sqlType (Proxy @UserId) testSqlTypeEquivalent(Proxy @Profile) describe "Profile2" $ do it "has same ID key type as User" $ do sqlType (Proxy @Profile2Id) `shouldBe` sqlType (Proxy @UserId) testSqlTypeEquivalent (Proxy @Profile2) describe "getEntityId FieldDef" $ do it "should match underlying primary key" $ do getSqlType (Proxy @User) `shouldBe` getSqlType (Proxy @Profile) describe "DayKeyTable" $ do testSqlTypeEquivalent (Proxy @DayKeyTable) it "sqlType has Day type" $ do sqlType (Proxy @Day) `shouldBe` sqlType (Proxy @DayKeyTableId) it "getSqlType has Day type" $ do sqlType (Proxy @Day) `shouldBe` getSqlType (Proxy @DayKeyTable) describe "RefDayKey" $ do let [dayKeyField] = getEntityFields (entityDef (Proxy @RefDayKey)) testSqlTypeEquivalent (Proxy @RefDayKey) it "has same sqltype as underlying" $ do fieldSqlType dayKeyField `shouldBe` sqlType (Proxy @Day) it "has the right fieldType" $ do fieldType dayKeyField `shouldBe` FTTypeCon Nothing "DayKeyTableId" it "has the right type" $ do let _ = refDayKeyDayKey :: RefDayKey -> DayKeyTableId _ = RefDayKeyDayKey :: EntityField RefDayKey DayKeyTableId True `shouldBe` True it "has a foreign ref" $ do case fieldReference dayKeyField of ForeignRef refName -> do refName `shouldBe` EntityNameHS "DayKeyTable" other -> fail $ "expected foreign ref, got: " <> show other persistent-2.14.6.0/test/Database/Persist/TH/SumSpec.hs0000644000000000000000000000152014476403105020674 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Persist.TH.SumSpec where import TemplateTestImports import Database.Persist.TH.MultiBlockSpec.Model share [ mkPersistWith sqlSettings importDefList ] [persistLowerCase| What name Text Lamp name Text +Please what WhatId lamp LampId |] spec :: Spec spec = do it "should warn" True persistent-2.14.6.0/test/Database/Persist/TH/ToFromPersistValuesSpec.hs0000644000000000000000000002103014476403105024066 0ustar0000000000000000{-# LANGUAGE DataKinds, ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- -- 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 qualified Data.List.NonEmpty as NEL instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where sqlType _ = SqlString instance PersistField a => PersistField (NonEmpty a) where toPersistValue = toPersistValue . NEL.toList fromPersistValue pv = do xs <- fromPersistValue pv case xs of [] -> Left "PersistField: NonEmpty found unexpected Empty List" (l:ls) -> Right (l:|ls) mkPersist sqlSettings [persistLowerCase| NormalModel name Text age Int deriving Eq Show PrimaryModel name Text age Int Primary name age deriving Eq Show IsMigrationOnly name Text age Int blargh Int MigrationOnly deriving Eq Show HasListField names [Text] deriving Eq Show HasNonEmptyListField names (NonEmpty Text) deriving Eq Show HasNonEmptyListKeyField names (NonEmpty (Key NormalModel)) deriving Eq Show |] spec :: Spec spec = describe "{to,from}PersistValues" $ do let toPersistValues :: PersistEntity rec => rec -> [PersistValue] toPersistValues = map toPersistValue . toPersistFields subject :: (PersistEntity rec, Show rec, Eq rec) => rec -> [PersistValue] -> Spec subject model fields = do it "toPersistValues" $ do toPersistValues model `shouldBe` fields it "fromPersistValues" $ do fromPersistValues fields `shouldBe` Right model describe "NormalModel" $ do subject (NormalModel "hello" 30) [ PersistText "hello" , PersistInt64 30 ] describe "PrimaryModel" $ do subject (PrimaryModel "hello" 30) [ PersistText "hello" , PersistInt64 30 ] describe "IsMigrationOnly" $ do subject (IsMigrationOnly "hello" 30) [ PersistText "hello" , PersistInt64 30 ] describe "mkInsertValues" $ do describe "NormalModel" $ do it "has all values" $ do mkInsertValues (NormalModel "hello" 30) `shouldBe` [ PersistText "hello" , PersistInt64 30 ] describe "PrimaryModel" $ do it "has all values" $ do mkInsertValues (PrimaryModel "hello" 30) `shouldBe` [ PersistText "hello" , PersistInt64 30 ] describe "IsMigrationOnly" $ do it "has all values" $ do mkInsertValues (IsMigrationOnly "hello" 30) `shouldBe` [ PersistText "hello" , PersistInt64 30 ] describe "parseEntityValues" $ do let subject :: forall rec. (PersistEntity rec, Show rec, Eq rec) => [PersistValue] -> Entity rec -> Spec subject pvs rec = it "parses" $ do parseEntityValues (entityDef (Proxy @rec)) pvs `shouldBe` Right rec describe "NormalModel" $ do subject [ PersistInt64 20 , PersistText "hello" , PersistInt64 30 ] Entity { entityKey = NormalModelKey 20 , entityVal = NormalModel "hello" 30 } describe "PrimaryModel" $ do subject [ PersistText "hey" , PersistInt64 30 ] Entity { entityKey = PrimaryModelKey "hey" 30 , entityVal = PrimaryModel "hey" 30 } describe "IsMigrationOnly" $ do subject [ PersistInt64 20 , PersistText "hello" , PersistInt64 30 ] Entity { entityKey = IsMigrationOnlyKey 20 , entityVal = IsMigrationOnly "hello" 30 } describe "entityValues" $ do let subject :: forall rec. (PersistEntity rec, Show rec, Eq rec) => [PersistValue] -> Entity rec -> Spec subject pvals entity = do it "renders as you would expect"$ do entityValues entity `shouldBe` pvals it "round trips with parseEntityValues" $ do parseEntityValues (entityDef $ Proxy @rec) (entityValues entity) `shouldBe` Right entity describe "NormalModel" $ do subject [ PersistInt64 10 , PersistText "hello" , PersistInt64 20 ] Entity { entityKey = NormalModelKey 10 , entityVal = NormalModel "hello" 20 } describe "PrimaryModel" $ do subject [ PersistText "hello" , PersistInt64 20 ] Entity { entityKey = PrimaryModelKey "hello" 20 , entityVal = PrimaryModel "hello" 20 } describe "IsMigrationOnly" $ do subject [ PersistInt64 20 , PersistText "hello" , PersistInt64 20 ] Entity { entityKey = IsMigrationOnlyKey 20 , entityVal = IsMigrationOnly "hello" 20 } describe "HasListField" $ do subject [ PersistInt64 10 , PersistList [PersistText "hello"] ] Entity { entityKey = HasListFieldKey 10 , entityVal = HasListField ["hello"] } describe "HasNonEmptyListField" $ do subject [ PersistInt64 10 , PersistList [PersistText "hello"] ] Entity { entityKey = HasNonEmptyListFieldKey 10 , entityVal = HasNonEmptyListField (pure "hello") } describe "HasNonEmptyListKeyField" $ do subject [ PersistInt64 5 , PersistList [PersistInt64 4] ] Entity { entityKey = HasNonEmptyListKeyFieldKey 5 , entityVal = HasNonEmptyListKeyField (pure (NormalModelKey 4)) } persistent-2.14.6.0/test/Database/Persist/TH/TypeLitFieldDefsSpec.hs0000644000000000000000000000330214476403105023270 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} module Database.Persist.TH.TypeLitFieldDefsSpec where import GHC.TypeLits import TemplateTestImports newtype Finite (n :: Nat) = Finite Int instance PersistField (Finite n) where toPersistValue (Finite n) = toPersistValue n fromPersistValue = fmap Finite . fromPersistValue instance PersistFieldSql (Finite n) where sqlType _ = sqlType (Proxy :: Proxy Int) newtype Labelled (t :: Symbol) = Labelled Int instance PersistField (Labelled n) where toPersistValue (Labelled n) = toPersistValue n fromPersistValue = fmap Labelled . fromPersistValue instance PersistFieldSql (Labelled n) where sqlType _ = sqlType (Proxy :: Proxy Int) mkPersist sqlSettings [persistLowerCase| WithFinite one (Finite 1) twenty (Finite 20) WithLabelled one (Labelled "one") twenty (Labelled "twenty") |] spec :: Spec spec = describe "TypeLitFieldDefs" $ do it "should support numeric type literal fields in entity definition" $ do let mkFinite :: Finite 1 -> Finite 20 -> WithFinite mkFinite = WithFinite compiles it "should support string based type literal fields in entity definition" $ do let mkLabelled :: Labelled "one" -> Labelled "twenty" -> WithLabelled mkLabelled = WithLabelled compiles compiles :: Expectation compiles = True `shouldBe` True persistent-2.14.6.0/test/Database/Persist/THSpec.hs0000644000000000000000000004746014507124116020142 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- -- 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 Data.Aeson (decode, encode) import Data.ByteString.Lazy.Char8 () import Data.Coerce import Data.Functor.Identity (Identity(..)) import Data.Int import qualified Data.List as List import Data.Proxy import Data.Text (Text, pack) import Data.Time import GHC.Generics (Generic) import System.Environment import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen (Gen) import Database.Persist import Database.Persist.EntityDef.Internal import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports import qualified Database.Persist.TH.CommentSpec as CommentSpec import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec import qualified Database.Persist.TH.EntityHaddockSpec as EntityHaddockSpec import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec import qualified Database.Persist.TH.KindEntitiesSpec as KindEntitiesSpec import qualified Database.Persist.TH.MaybeFieldDefsSpec as MaybeFieldDefsSpec import qualified Database.Persist.TH.MigrationOnlySpec as MigrationOnlySpec import qualified Database.Persist.TH.MultiBlockSpec as MultiBlockSpec import qualified Database.Persist.TH.NestedSymbolsInTypeSpec as NestedSymbolsInTypeSpec import qualified Database.Persist.TH.NoFieldSelectorsSpec as NoFieldSelectorsSpec import qualified Database.Persist.TH.OverloadedLabelSpec as OverloadedLabelSpec import qualified Database.Persist.TH.PersistWithSpec as PersistWithSpec import qualified Database.Persist.TH.RequireOnlyPersistImportSpec as RequireOnlyPersistImportSpec import qualified Database.Persist.TH.SharedPrimaryKeyImportedSpec as SharedPrimaryKeyImportedSpec import qualified Database.Persist.TH.SharedPrimaryKeySpec as SharedPrimaryKeySpec import qualified Database.Persist.TH.SumSpec as SumSpec import qualified Database.Persist.TH.ToFromPersistValuesSpec as ToFromPersistValuesSpec import qualified Database.Persist.TH.TypeLitFieldDefsSpec as TypeLitFieldDefsSpec -- test to ensure we can have types ending in Id that don't trash the TH -- machinery type TextId = Text share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase| Person json name Text age Int Maybe foo Foo address Address deriving Show Eq HasSimpleCascadeRef person PersonId OnDeleteCascade deriving Show Eq Address json street Text city Text zip Int Maybe deriving Show Eq NoJson foo Text deriving Show Eq CustomIdName Id sql=id_col name Text deriving Show Eq QualifiedReference jsonEncoding JsonEncodingSpec.JsonEncodingId |] mkPersist sqlSettings [persistLowerCase| HasPrimaryDef userId Int name String Primary userId HasMultipleColPrimaryDef foobar Int barbaz String Primary foobar barbaz TestDefaultKeyCol Id TestDefaultKeyColId name String HasIdDef Id Int name String HasDefaultId name String HasCustomSqlId Id String sql=my_id name String SharedPrimaryKey Id HasDefaultIdId name String SharedPrimaryKeyWithCascade Id (Key HasDefaultId) OnDeleteCascade name String SharedPrimaryKeyWithCascadeAndCustomName Id (Key HasDefaultId) OnDeleteCascade sql=my_id name String Top name Text Middle top TopId Primary top Bottom middle MiddleId Primary middle -- Test that a field can be named Key KeyTable key Text |] share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase| Lperson json name Text age Int Maybe address Laddress deriving Show Eq Laddress json street Text city Text zip Int Maybe deriving Show Eq CustomPrimaryKey anInt Int Primary anInt |] arbitraryT :: Gen Text arbitraryT = pack <$> arbitrary instance Arbitrary Person where arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Address where arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary spec :: Spec spec = describe "THSpec" $ do describe "SumSpec" $ SumSpec.spec PersistWithSpec.spec KindEntitiesSpec.spec NestedSymbolsInTypeSpec.spec OverloadedLabelSpec.spec SharedPrimaryKeySpec.spec SharedPrimaryKeyImportedSpec.spec ImplicitIdColSpec.spec MaybeFieldDefsSpec.spec TypeLitFieldDefsSpec.spec MigrationOnlySpec.spec NoFieldSelectorsSpec.spec EmbedSpec.spec DiscoverEntitiesSpec.spec MultiBlockSpec.spec ForeignRefSpec.spec ToFromPersistValuesSpec.spec JsonEncodingSpec.spec CommentSpec.spec EntityHaddockSpec.spec CompositeKeyStyleSpec.spec it "QualifiedReference" $ do let ed = entityDef @QualifiedReference Proxy [FieldDef {..}] = entityFields ed fieldType `shouldBe` FTTypeCon (Just "JsonEncodingSpec") "JsonEncodingId" fieldSqlType `shouldBe` sqlType @JsonEncodingSpec.JsonEncodingId Proxy fieldReference `shouldBe` ForeignRef (EntityNameHS "JsonEncoding") describe "TestDefaultKeyCol" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @TestDefaultKeyCol)) it "should be a BackendKey SqlBackend" $ do -- the purpose of this test is to verify that a custom Id column of -- the form: -- > ModelName -- > Id ModelNameId -- -- should behave like an implicit id column. (TestDefaultKeyColKey (SqlBackendKey 32) :: Key TestDefaultKeyCol) `shouldBe` (toSqlKey 32 :: Key TestDefaultKeyCol) describe "HasDefaultId" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @HasDefaultId)) it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id" it "should have usual haskell name" $ do fieldHaskell `shouldBe` FieldNameHS "Id" it "should have correct underlying sql type" $ do fieldSqlType `shouldBe` SqlInt64 it "persistfieldsql should be right" $ do sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64 it "should have correct haskell type" $ do fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId" describe "HasCustomSqlId" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @HasCustomSqlId)) it "should have custom db name" $ do fieldDB `shouldBe` FieldNameDB "my_id" it "should have usual haskell name" $ do fieldHaskell `shouldBe` FieldNameHS "Id" it "should have correct underlying sql type" $ do fieldSqlType `shouldBe` SqlString it "should have correct haskell type" $ do fieldType `shouldBe` FTTypeCon Nothing "String" describe "HasIdDef" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @HasIdDef)) it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id" it "should have usual haskell name" $ do fieldHaskell `shouldBe` FieldNameHS "Id" it "should have correct underlying sql type" $ do fieldSqlType `shouldBe` SqlInt64 it "should have correct haskell type" $ do fieldType `shouldBe` FTTypeCon Nothing "Int" describe "SharedPrimaryKey" $ do let sharedDef = entityDef (Proxy @SharedPrimaryKey) EntityIdField FieldDef{..} = entityId sharedDef it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id" it "should have usual haskell name" $ do fieldHaskell `shouldBe` FieldNameHS "Id" it "should have correct underlying sql type" $ do fieldSqlType `shouldBe` SqlInt64 it "should have correct underlying (as reported by sqltype)" $ do fieldSqlType `shouldBe` sqlType (Proxy :: Proxy HasDefaultIdId) it "should have correct haskell type" $ do fieldType `shouldBe` (FTTypeCon Nothing "HasDefaultIdId") it "should have correct sql type from PersistFieldSql" $ do sqlType (Proxy @SharedPrimaryKeyId) `shouldBe` SqlInt64 it "should have same sqlType as underlying record" $ do sqlType (Proxy @SharedPrimaryKeyId) `shouldBe` sqlType (Proxy @HasDefaultIdId) it "should be a coercible newtype" $ do coerce @Int64 3 `shouldBe` SharedPrimaryKeyKey (toSqlKey 3) describe "SharedPrimaryKeyWithCascade" $ do let EntityIdField FieldDef{..} = entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade)) it "should have usual db name" $ do fieldDB `shouldBe` FieldNameDB "id" it "should have usual haskell name" $ do fieldHaskell `shouldBe` FieldNameHS "Id" it "should have correct underlying sql type" $ do fieldSqlType `shouldBe` SqlInt64 it "should have correct haskell type" $ do fieldType `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") it "should have cascade in field def" $ do fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade } describe "OnCascadeDelete" $ do let subject :: FieldDef Just subject = List.find ((FieldNameHS "person" ==) . fieldHaskell) $ entityFields $ simpleCascadeDef simpleCascadeDef = entityDef (Proxy :: Proxy HasSimpleCascadeRef) expected = FieldCascade { fcOnDelete = Just Cascade , fcOnUpdate = Nothing } describe "entityDef" $ do it "works" $ do simpleCascadeDef `shouldBe` EntityDef { entityHaskell = EntityNameHS "HasSimpleCascadeRef" , entityDB = EntityNameDB "HasSimpleCascadeRef" , entityId = EntityIdField FieldDef { fieldHaskell = FieldNameHS "Id" , fieldDB = FieldNameDB "id" , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId" , fieldSqlType = SqlInt64 , fieldReference = NoReference , fieldAttrs = [] , fieldStrict = True , fieldComments = Nothing , fieldCascade = noCascade , fieldGenerated = Nothing , fieldIsImplicitIdColumn = True } , entityAttrs = [] , entityFields = [ FieldDef { fieldHaskell = FieldNameHS "person" , fieldDB = FieldNameDB "person" , fieldType = FTTypeCon Nothing "PersonId" , fieldSqlType = SqlInt64 , fieldAttrs = [] , fieldStrict = True , fieldReference = ForeignRef (EntityNameHS "Person") , fieldCascade = FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade } , fieldComments = Nothing , fieldGenerated = Nothing , fieldIsImplicitIdColumn = False } ] , entityUniques = [] , entityForeigns = [] , entityDerives = ["Show", "Eq"] , entityExtra = mempty , entitySum = False , entityComments = Nothing } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected it "doesn't have any extras" $ do entityExtra simpleCascadeDef `shouldBe` mempty describe "hasNaturalKey" $ do let subject :: PersistEntity a => Proxy a -> Bool subject p = hasNaturalKey (entityDef p) it "is True for Primary keyword" $ do subject (Proxy @HasPrimaryDef) `shouldBe` True it "is True for multiple Primary columns " $ do subject (Proxy @HasMultipleColPrimaryDef) `shouldBe` True it "is False for Id keyword" $ do subject (Proxy @HasIdDef) `shouldBe` False it "is False for unspecified/default id" $ do subject (Proxy @HasDefaultId) `shouldBe` False describe "hasCompositePrimaryKey" $ do let subject :: PersistEntity a => Proxy a -> Bool subject p = hasCompositePrimaryKey (entityDef p) it "is False for Primary with single column" $ do subject (Proxy @HasPrimaryDef) `shouldBe` False it "is True for multiple Primary columns " $ do subject (Proxy @HasMultipleColPrimaryDef) `shouldBe` True it "is False for Id keyword" $ do subject (Proxy @HasIdDef) `shouldBe` False it "is False for unspecified/default id" $ do subject (Proxy @HasDefaultId) `shouldBe` False describe "JSON serialization" $ do prop "to/from is idempotent" $ \person -> decode (encode person) == Just (person :: Person) it "decode" $ decode "{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing) describe "JSON serialization for Entity" $ do let key = PersonKey 0 prop "to/from is idempotent" $ \person -> decode (encode (Entity key person)) == Just (Entity key (person :: Person)) it "decode" $ decode "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just (Entity key (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing)) it "lens operations" $ do let street1 = "street1" city1 = "city1" city2 = "city2" zip1 = Just 12345 address1 = Laddress street1 city1 zip1 address2 = Laddress street1 city2 zip1 name1 = "name1" age1 = Just 27 person1 = Lperson name1 age1 address1 person2 = Lperson name1 age1 address2 (person1 ^. lpersonAddress) `shouldBe` address1 (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1 (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2 describe "Derived Show/Read instances" $ do -- This tests confirms https://github.com/yesodweb/persistent/issues/1104 remains fixed it "includes the name of the newtype when showing/reading a Key, i.e. uses the stock strategy when deriving Show/Read" $ do show (PersonKey 0) `shouldBe` "PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 0}}" read (show (PersonKey 0)) `shouldBe` PersonKey 0 show (CustomPrimaryKeyKey 0) `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}" read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0 describe "tabulateEntityA" $ do it "works" $ do person <- tabulateEntityA $ \case PersonName -> pure "Matt" PersonAge -> do (year, _, _) <- toGregorian . utctDay <$> getCurrentTime pure $ Just (fromInteger year - 1988) PersonFoo -> do _ <- lookupEnv "PERSON_FOO" :: IO (Maybe String) pure Bar PersonAddress -> pure $ Address "lol no" "Denver" Nothing PersonId -> pure $ toSqlKey 123 expectedAge <- fromInteger . subtract 1988 . (\(a, _, _) -> a) . toGregorian . utctDay <$> getCurrentTime person `shouldBe` Entity (toSqlKey 123) Person { personName = "Matt" , personAge = Just expectedAge , personFoo = Bar , personAddress = Address "lol no" "Denver" Nothing } describe "tabulateEntity" $ do it "works" $ do let addressTabulate = tabulateEntity $ \case AddressId -> toSqlKey 123 AddressStreet -> "nope" AddressCity -> "Denver" AddressZip -> Nothing addressTabulate `shouldBe` Entity (toSqlKey 123) Address { addressStreet = "nope" , addressCity = "Denver" , addressZip = Nothing } describe "CustomIdName" $ do it "has a good safe to insert class instance" $ do let proxy = Proxy :: SafeToInsert CustomIdName => Proxy CustomIdName proxy `shouldBe` Proxy (&) :: a -> (a -> b) -> b x & f = f x (^.) :: s -> ((a -> Const a b) -> (s -> Const a t)) -> a x ^. lens = getConst $ lens Const x (.~) :: ((a -> Identity b) -> (s -> Identity t)) -> b -> s -> t lens .~ val = runIdentity . lens (\_ -> Identity val) persistent-2.14.6.0/test/TemplateTestImports.hs0000644000000000000000000000122014476403105017633 0ustar0000000000000000{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} module TemplateTestImports ( module TemplateTestImports , module X ) where import Data.Aeson.TH import Test.QuickCheck import Data.Int as X import Database.Persist.Sql as X import Database.Persist.TH as X import Test.Hspec as X import Data.Proxy as X import Data.Text as X (Text) import Data.Maybe import Control.Monad import Language.Haskell.TH.Syntax data Foo = Bar | Baz deriving (Show, Eq) deriveJSON defaultOptions ''Foo derivePersistFieldJSON "Foo" instance Arbitrary Foo where arbitrary = elements [Bar, Baz] persistent-2.14.6.0/bench/Main.hs0000644000000000000000000001104514476403105014634 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where import Control.DeepSeq import Criterion.Main import Data.Text (Text) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Database.Persist.Quasi import Database.Persist.TH import Models main :: IO () main = defaultMain [ bgroup "mkPersist" [ -- bench "From File" $ nfIO $ mkPersist' $(persistFileWith lowerCaseSettings "bench/models-slowly") -- , bgroup "Non-Null Fields" -- [ bgroup "Increasing model count" -- [ bench "1x10" $ nfIO $ mkPersist' $( parseReferencesQ (mkModels 10 10)) -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10)) -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 100 10)) -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 1000 10)) -- ] -- , bgroup "Increasing field count" -- [ bench "10x1" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1)) -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10)) -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 100)) -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1000)) -- ] -- ] -- , bgroup "Nullable" -- [ bgroup "Increasing model count" -- [ bench "20x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 20 10)) -- , bench "40x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 40 10)) -- , bench "60x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 60 10)) -- , bench "80x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 80 10)) -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 100 10)) -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 1000 10)) -- ] -- , bgroup "Increasing field count" -- [ bench "10x20" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 20)) -- , bench "10x40" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 40)) -- , bench "10x60" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 60)) -- , bench "10x80" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 80)) -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 100)) -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 1000)) -- ] -- ] ] ] -- Orphan instances for NFData Template Haskell types instance NFData Overlap 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 instance NFData Pragma where instance NFData FixityDirection where instance NFData Safety where instance NFData Fixity where instance NFData Callconv where instance NFData Foreign where instance NFData SourceStrictness where instance NFData SourceUnpackedness where instance NFData FunDep where instance NFData Bang where #if MIN_VERSION_template_haskell(2,12,0) instance NFData PatSynDir where instance NFData PatSynArgs where instance NFData DerivStrategy where instance NFData DerivClause where #endif instance NFData Con where instance NFData Range where instance NFData Clause where instance NFData PkgName where instance NFData Dec where instance NFData Stmt where instance NFData TyLit where instance NFData NameSpace where instance NFData Body where instance NFData Guard where instance NFData Match where instance NFData ModName where instance NFData Pat where #if MIN_VERSION_template_haskell(2,16,0) instance NFData Bytes where rnf !_ = () #endif #if MIN_VERSION_template_haskell(2,17,0) instance NFData a => NFData (TyVarBndr a) where instance NFData Specificity #else instance NFData TyVarBndr where #endif instance NFData NameFlavour where instance NFData Type where instance NFData Exp where instance NFData Lit where instance NFData OccName where instance NFData Name where persistent-2.14.6.0/bench/Models.hs0000644000000000000000000000315014476403105015171 0ustar0000000000000000module Models where import Data.Monoid import Language.Haskell.TH import qualified Data.Text as Text import Database.Persist.Quasi import Database.Persist.Quasi.Internal import Database.Persist.TH import Database.Persist.Sql -- TODO: we use lookupName and reify etc which breaks in IO. somehow need to -- test this out elsewise mkPersist' :: [UnboundEntityDef] -> IO [Dec] mkPersist' = runQ . mkPersist sqlSettings parseReferences' :: String -> IO Exp parseReferences' = runQ . parseReferencesQ parseReferencesQ :: String -> Q Exp parseReferencesQ = parseReferences lowerCaseSettings . Text.pack -- | # of models, # of fields mkModels :: Int -> Int -> String mkModels = mkModelsWithFieldModifier id mkNullableModels :: Int -> Int -> String mkNullableModels = mkModelsWithFieldModifier maybeFields mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String mkModelsWithFieldModifier k i f = unlines . fmap unlines . take i . map mkModel . zip [0..] . cycle $ [ "Model" , "Foobar" , "User" , "King" , "Queen" , "Dog" , "Cat" ] where mkModel :: (Int, String) -> [String] mkModel (i', m) = (m <> show i') : indent 4 (map k (mkFields f)) indent :: Int -> [String] -> [String] indent i = map (replicate i ' ' ++) mkFields :: Int -> [String] mkFields i = take i $ map mkField $ zip [0..] $ cycle [ "Bool" , "Int" , "String" , "Double" , "Text" ] where mkField :: (Int, String) -> String mkField (i', typ) = "field" <> show i' <> "\t\t" <> typ maybeFields :: String -> String maybeFields = (++ " Maybe") persistent-2.14.6.0/ChangeLog.md0000644000000000000000000010417014507124122014502 0ustar0000000000000000# Changelog for persistent ## 2.14.6.0 * [#1477](https://github.com/yesodweb/persistent/pull/1477) * Qualified references to other tables will work * [#1503](https://github.com/yesodweb/persistent/pull/1503) * Create Haddocks from entity documentation comments * [1497](https://github.com/yesodweb/persistent/pull/1497) * Always generates `SymbolToField "id"` instance * [#1509](https://github.com/yesodweb/persistent/pull/1509) * Provide `ViaPersistEntity` for defining `PathMultiPiece` for entity keys. * [#1480](https://github.com/yesodweb/persistent/pull/1480) * Add `mpsAvoidHsKeyword` in `MkPersistSettings` * ## 2.14.5.2 * [#1513](https://github.com/yesodweb/persistent/pull/1513) * Support GHC 9.8 and `aeson-2.2` ## 2.14.5.1 * [#1496](https://github.com/yesodweb/persistent/pull/1496) * Fixes name shadowing error at the generated `keyFromRecordM` function. * [#1505](https://github.com/yesodweb/persistent/pull/1505) * Fixes the comment line parsing rule so that accommodates paragraph breaks. ## 2.14.5.0 * [#1469](https://github.com/yesodweb/persistent/pull/1469) * Change default implementation for `insertUnique_` to not perform unecessary queries (mirrors 1449) * [#1437](https://github.com/yesodweb/persistent/pull/1437) * Add `existsBy` to `PersistUniqueRead` ## 2.14.4.5 * [#1460](https://github.com/yesodweb/persistent/pull/1468) * Remove extraneous `map toPersistValue` call in the `mkInsertValues` function, as it evaluates to `id`. * [#1476](https://github.com/yesodweb/persistent/pull/1476) * Fix `mkRecordName` to suffix `_` if the field name matches any of Haskell keywords. ## 2.14.4.4 * [#1460](https://github.com/yesodweb/persistent/pull/1460) * Fix a problem where a `Primary` key causes `mkPersist` to generate code that doesn't compile under `NoFieldSelectors` ## 2.14.4.3 * [#1452](https://github.com/yesodweb/persistent/pull/1452) * Implement `repsert` as a special case of `respertMany`. Allows backend specific behavior. ## 2.14.4.2 * [#1451](https://github.com/yesodweb/persistent/pull/1451) * Support `mtl >= 2.3` ## 2.14.4.1 * [#1449](https://github.com/yesodweb/persistent/pull/1449) * Default implementation for `insert_` which doesn't perform any unnecessary queries. ## 2.14.4.0 * [#1440](https://github.com/yesodweb/persistent/pull/1440) * Defined NFData PersistValue ## 2.14.3.2 * [#1446](https://github.com/yesodweb/persistent/pull/1446) * Foreign key discovery was fixed for qualified names, `Key Model`, and `Maybe` references. * [#1438](https://github.com/yesodweb/persistent/pull/1438) * Clarify wording on the error message for null in unique constraint * [#1447](https://github.com/yesodweb/persistent/pull/1447) * Fix `SafeToInsert` not being generated correctly for some `Id` columns ## 2.14.3.1 * [#1428](https://github.com/yesodweb/persistent/pull/1428) * Fix that the documentation for `discoverEntities` was not being generated. ## 2.14.3.0 * [#1425](https://github.com/yesodweb/persistent/pull/1425) * Introduce an alias `setPsUseSnakeCaseForeignKeys` for `setPsUseSnakeCaseForiegnKeys` due to a typo in the latter; deprecate `setPsUseSnakeCaseForiegnKeys` ## 2.14.2.0 * [#1421](https://github.com/yesodweb/persistent/pull/1421) * Add `mpsCamelCaseCompositeKeySelector` field to `MkPersistSettings`, which define the style of the entity's composite key. ## 2.14.1.0 * [#1418](https://github.com/yesodweb/persistent/pull/1418/) * Re-export `SafeToInsert` from `Database.Persist.Class`, which should re-export it through `Database.Persist`, `Database.Persist.Sql`, etc. * [#1409](https://github.com/yesodweb/persistent/pull/1409) * Fix incorrect reference to rawSql in documentation. ## 2.14.0.3 * [#1411](https://github.com/yesodweb/persistent/pull/1411) * Fix the docs for `FieldNameDB`, and update `FieldDef.fieldComments` docs since the quasiquoter *supports* field comments now. ## 2.14.0.2 * [#1407](https://github.com/yesodweb/persistent/pull/1407) * Fix a name shadowing warning. ## 2.14.0.1 * [#1392](https://github.com/yesodweb/persistent/pull/1392) * Enhance `selectList` documentation with TypeApplications examples. * Clarify `selectSource` documentation wording. * [#1391](https://github.com/yesodweb/persistent/pull/1391) * Increasing quasi module test coverage, improve error assertions * [#1401](https://github.com/yesodweb/persistent/pull/1401) * Change `Entity` back into a regular record and drop the `HasField` instance. This is technically a breaking change, but [the bug in GHC's `COMPLETE` annotations](https://gitlab.haskell.org/ghc/ghc/-/issues/15681) rendered a super common pattern a much more invasive breaking change than anticipated. As a result, upgrading to `persistent-2.14` was untenable. If you *did* upgrade and this broke your codebase *again*, please let me know and I can release another patch to shim it. ## 2.14.0.0 * [#1343](https://github.com/yesodweb/persistent/pull/1343) * Implement Type Literal based field definitions * [#1387](https://github.com/yesodweb/persistent/pull/1387) * Better UX with `insert`. We now report a type error when you try to `insert` an `Entity` or a function, and we also forbid `insert`ing if the database would throw an error missing a primary key. * [#1383](https://github.com/yesodweb/persistent/pull/1383) * Primary keys have a `NonEmpty` of fields, not a `[]` of fields. * A `Primary` key on an entity now creates a `Unique` constructror for that record, with the name `#{entityName}PrimaryKey`. This also affects the generation of `AtLeastOneUniqueKey` and `OnlyOneUniqueKey` instances, so you may need to change behavior on these classes. * [#1381](https://github.com/yesodweb/persistent/pull/1381) * `Entity` is given a `HasField` instance that uses the database field names. This is primarily done to support `OverloadedRecordDot` in GHC 9.2 and above. * A consequence of this is that the `Entity` constructor has been renamed to `Entity'`. A pattern synonym is provided that should work in almost all cases. You may incur a `MonadFail m` constraint if you are pattern matching directly on the constructor in a `do` result. * [#1364](https://github.com/yesodweb/persistent/pull/1346) * The type `SomePersistField` was removed in favor of using `PersistValue` directly. * [#1386](https://github.com/yesodweb/persistent/pull/1386) * The module `Database.Persist.Class.DeleteCascade` was deleted since you can put cascade behavior directly on your database models. * Removed `mkSave` from `Database.Persist.TH`. Use `mkEntityDefList` instead. * Remove the `CompositeDef` constructor from `ReferenceDef` which was not used internally anymore. * [#1385](https://github.com/yesodweb/persistent/pull/1385) * The support for entity-level sum types is deprecated. It adds a considerable amount of complexity to the code, and the pattern is not particularly good for actually supporting sum types in most databases. * [#1384](https://github.com/yesodweb/persistent/pull/1384) * Add `tabulateEntityA` to the `PersistEntity` class, allowing you to construct an `Entity a` by providing a function `EntityField a t -> f t`. Note that this doesn't make sense for sum entities, and the implementation `error`s. * Add `tabulateEntity` as a pure version of that. ## 2.13.3.5 * [#1374](https://github.com/yesodweb/persistent/pull/1374) * Increasing test coverage for errors thrown when parsing entity definitions ## 2.13.3.4 * [#1379](https://github.com/yesodweb/persistent/pull/1379) * `mkPersist` now generates code that compiles under `NoFieldSelectors` and `DuplicateRecordFields` even if field labels are not prefixed * [#1376](https://github.com/yesodweb/persistent/pull/1376) * Add coverage for parsing nested parens/lists in field types * [#1370](https://github.com/yesodweb/persistent/pull/1370) * Add spec to assert Persistent.TH is the only import required when defining entities ## 2.13.3.3 * [#1369](https://github.com/yesodweb/persistent/pull/1369) * Fix `withObject` needing to be imported ## 2.13.3.2 * [#1315](https://github.com/yesodweb/persistent/pull/1315) * Refactor entity constraint parsing in Quasi module ## 2.13.3.1 * [#1367](https://github.com/yesodweb/persistent/pull/1367), [#1366](https://github.com/yesodweb/persistent/pull/1367), [#1338](https://github.com/yesodweb/persistent/pull/1338), [#1335](https://github.com/yesodweb/persistent/pull/1335) * Support GHC 9.2 * [#1356](https://github.com/yesodweb/persistent/pull/1356) * Improve parse errors in generated FromJSON instances ## 2.13.3.0 * [#1341](https://github.com/yesodweb/persistent/pull/1341) * Add `SqlBackendHooks` to allow for instrumentation of queries. * [#1327](https://github.com/yesodweb/persistent/pull/1327) * Update `SqlBackend` to use new `StatementCache` interface instead of `IORef (Map Text Statement)` ## 2.13.2.2 * [#1351](https://github.com/yesodweb/persistent/pull/1351/) * `aeson-2.0` support ## 2.13.2.1 * [#1329](https://github.com/yesodweb/persistent/pull/1329) * Prevent discovery of constrained `PersistEntity` instances in `discoverEntities` (since the discovered instances won't work without constraints anyway). ## 2.13.2.0 * [#1314](https://github.com/yesodweb/persistent/pull/1314) * Fix typos and minor documentation issues in Database.Persist and Database.Persist.Quasi. * [#1317](https://github.com/yesodweb/persistent/pull/1317) * Expose `orderClause` from the Persistent internals, which allows users to produce well-formatted `ORDER BY` clauses. * [#1319](https://github.com/yesodweb/persistent/pull/1319) * Add a `Num` instance for `OverflowNatural` ## 2.13.1.2 * [#1308](https://github.com/yesodweb/persistent/pull/1308) * Consolidate the documentation for the Persistent quasiquoter in Database.Persist.Quasi. * [#1312](https://github.com/yesodweb/persistent/pull/1312) * Reorganize documentation and link to more modules. * Expose `Database.Persist.Sql.Migration` ## 2.13.1.1 * [#1294](https://github.com/yesodweb/persistent/pull/1294) * Fix an issue where documentation comments on fields are in reverse line order. ## 2.13.1.0 * [#1264](https://github.com/yesodweb/persistent/pull/1264) * Support declaring Maybe before the type in model definitions ## 2.13.0.4 * [#1277](https://github.com/yesodweb/persistent/pull/1277) * Corrected the documentation of `addMigration` to match the actual behaviour - this will not change the behaviour of your code. ## 2.13.0.3 * [#1287](https://github.com/yesodweb/persistent/pull/1287) * Fix the duplicate entity check for transitive dependencies. * Fixes an issue where generating code would refer to the `ModelName` when making a reference to another table when the explicit code only refers to `ModelNameId`. ## 2.13.0.2 * [#1265](https://github.com/yesodweb/persistent/pull/1265) * Support GHC 9 ## 2.13.0.1 * [#1268](https://github.com/yesodweb/persistent/pull/1268) * Show `keyFromValues` error ## 2.13.0.0 * [#1244](https://github.com/yesodweb/persistent/pull/1244) * Implement config for customising the FK name * [#1252](https://github.com/yesodweb/persistent/pull/1252) * `mkMigrate` now defers to `mkEntityDefList` and `migrateModels` instead of fixing the foreign key references itself. * `mkSave` was deprecated - the function did not fix foreign key references. Please use `mkEntityDefList` instead. * `EntityDef` will now include fields marked `MigrationOnly` and `SafeToRemove`. Beforehand, those were filtered out, and `mkMigrate` applied. The function `getEntityFields` will only return fields defined on the Haskell type - for all columns, see `getEntityFieldsDatabase`. * [#1225](https://github.com/yesodweb/persistent/pull/1225) * The fields and constructor for `SqlBackend` are no longer exported by default. They are available from an internal module, `Database.Persist.Sql.Types.Internal`. Breaking changes from `Internal` modules are not reflected in the major version. This will allow us to release new functionality without breaking your code. It's recommended to switch to using the smart constructor functions and setter functions that are now exported from `Database.Persist.Sql` instead. * A new API is available for constructing and using a `SqlBackend`, provided in `Database.Persist.SqlBackend`. Instead of using the `SqlBackend` directly, use `mkSqlBackend` and the datatype `MkSqlBackendArgs`. The `MkSqlBackendArgs` record has the same field names as the `SqlBackend`, so the translation is easy: ```diff - SqlBackend + mkSqlBackend MkSqlBackendArgs { connInsertSql = ... , connCommit = ... , connEscapeFieldName = ... , connEscapeTableName = ... , etc } ``` Some fields were omitted in `MkSqlBackendArgs`. These fields are *optional* - they provide enhanced or backend-specific functionality. For these, use the setter functions like `setConnUpsertSql`. * Previously hidden modules are now exposed under the `Internal` namespace. * The `connLimitOffset` function used to have a `Bool` parameter. This parameter is unused and has been removed. * [#1234](https://github.com/yesodweb/persistent/pull/1234) * You can now customize the default implied ID column. See the documentation in `Database.Persist.ImplicitIdDef` for more details. * Moved the various `Name` types into `Database.Persist.Names` * Removed the `hasCompositeKey` function. See `hasCompositePrimaryKey` and `hasNaturalKey` as replacements. * The `EntityDef` constructor and field labels are not exported by default. Get those from `Database.Persist.EntityDef.Internal`, but you should migrate to the getters/setters in `Database.Persist.EntityDef` as you can. * Added the `Database.Persist.FieldDef` and `Database.Persist.FieldDef.Internal` modules. * The `PersistSettings` type was made abstract. Please migrate to the getters/setters defined in that `Database.Persist.Quasi`, or use `Database.Persist.Quasi.Internal` if you don't mind the possibility of breaking changes. * Add the `runSqlCommand` function for running arbitrary SQL during migrations. * Add `migrateModels` function for a TH-free migration facility. * [#1253](https://github.com/yesodweb/persistent/pull/1253) * Add `discoverEntities` to discover instances of the class and return their entity definitions. * [#1250](https://github.com/yesodweb/persistent/pull/1250) * The `mpsGeneric` function has been deprecated. If you need this functionality, please comment with your needs on the GitHub issue tracker. We may un-deprecate it, or we may provide a new and better means of facilitating a solution to your problem. * [#1255](https://github.com/yesodweb/persistent/pull/1255) * `mkPersist` now checks to see if an instance already exists for `PersistEntity` for the inputs. * [#1256](https://github.com/yesodweb/persistent/pull/1256) * The QuasiQuoter has been refactored and improved. * You can now use `mkPersistWith` to pass in a list of pre-existing `EntityDef` to improve foreign key detection and splitting up models across multiple modules. * The `entityId` field now returns an `EntityIdDef`, which specifies what the ID field actually is. This is a move to better support natural keys. * Several types that had lists have been refactored to use nonempty lists to better capture the semantics. * `mkDeleteCascade` is deprecated. Please use the Cascade behavior directly on fields. * You can use `Key Foo` and `FooId` interchangeably in fields. * Support for GHC < 8.4 dropped. ## 2.12.1.2 * [#1258](https://github.com/yesodweb/persistent/pull/1258) * Support promoted types in Quasi Quoter * [#1243](https://github.com/yesodweb/persistent/pull/1243) * Assorted cleanup of TH module * [#1242](https://github.com/yesodweb/persistent/pull/1242) * Refactor setEmbedField to use do notation * [#1237](https://github.com/yesodweb/persistent/pull/1237) * Remove nonEmptyOrFail function from recent tests ## 2.12.1.1 * [#1231](https://github.com/yesodweb/persistent/pull/1231) * Simplify Line type in Quasi module, always use NonEmpty * [#1229](https://github.com/yesodweb/persistent/pull/1229) * The `#id` labels are now generated for entities. ## 2.12.1.0 * [#1218](https://github.com/yesodweb/persistent/pull/1218) * Refactoring name generating functions in TH * [#1226](https://github.com/yesodweb/persistent/pull/1226) * Expose the `filterClause` and `filterClauseWithValues` functions to support the `upsertWhere` functionality in `persistent-postgresql`. ## 2.12.0.2 * [#1123](https://github.com/yesodweb/persistent/pull/1223) * Fix JSON encoding for `PersistValue` ## 2.12.0.1 * Refactoring token parsing in quasi module [#1206](https://github.com/yesodweb/persistent/pull/1206) * Removing duplication from TH output [#1202](https://github.com/yesodweb/persistent/pull/1202) * Refactor [] to NonEmpty in Quasi module [#1193](https://github.com/yesodweb/persistent/pull/1193) * [#1162](https://github.com/yesodweb/persistent/pull/1162) * Replace `askLogFunc` with `askLoggerIO` * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) * Use `resourcet-pool` to break out some `Data.Pool` logic [#1163](https://github.com/yesodweb/persistent/pull/1163) * [#1178](https://github.com/yesodweb/persistent/pull/1178) * Added 'withBaseBackend', 'withCompatible' to ease use of base/compatible backend queries in external code. * Added GHC 8.2.2 and GHC 8.4.4 back into the CI and `persistent` builds on 8.2.2 again [#1181](https://github.com/yesodweb/persistent/issues/1181) * [#1179](https://github.com/yesodweb/persistent/pull/1179) * Added `Compatible`, a newtype for marking a backend as compatible with another. Use it with `DerivingVia` to derive simple instances based on backend compatibility. * Added `makeCompatibleInstances` and `makeCompatibleKeyInstances`, TemplateHaskell invocations for auto-generating standalone derivations using `Compatible` and `DerivingVia`. * [#1207](https://github.com/yesodweb/persistent/pull/1207) * @codygman discovered a bug in [issue #1199](https://github.com/yesodweb/persistent/issues/1199) where postgres connections were being returned to the `Pool SqlBackend` in an inconsistent state. @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug. Fortunately, this doesn't affect the public API, and can be a mere bug release. * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`. * Renaming values in persistent-template [#1203](https://github.com/yesodweb/persistent/pull/1203) * [#1214](https://github.com/yesodweb/persistent/pull/1214): * Absorbed the `persistent-template` package. `persistent-template` will receive a 2.12 release with a warning and a deprecation notice. * Remove the `nooverlap` flag. It wasn't being used anymore. * [#1205](https://github.com/yesodweb/persistent/pull/1205) * Introduce the `PersistLiteral_` constructor, replacing the `PersistLiteral`, `PersistLiteralEscaped`, and `PersistDbSpecific`. * The old constructors are now pattern synonyms. They don't actually differentiate between the various escaping strategies when consuming them! If you pattern match on multiple of `PersistDbSpecific`, `PersistLiteral`, or `PersistLiteralEscaped` , then you should use the `PersistLiteral_` constructor to differentiate between them. ## 2.11.0.2 * Fix a bug where an empty entity definition would break parsing of `EntityDef`s. [#1176](https://github.com/yesodweb/persistent/issues/1176) ## 2.11.0.1 * Docs/Bugs fixes [#1153](https://github.com/yesodweb/persistent/pull/1153) * Fix documentation on `FieldDef.fieldAttrs`. * Postgresql backend: Add a space in cascade clause of generated SQL. ## 2.11.0.0 * Foreign Key improvements [#1121](https://github.com/yesodweb/persistent/pull/1121) * It is now supported to refer to a table with an auto generated Primary Kay * It is now supported to refer to non-primary fields, using the keyword `References` * It is now supported to have cascade options for simple/single-field Foreign Keys * Introduces a breaking change to the internal function `mkColumns`, which can now be passed a record of functions to override its default behavior. [#996](https://github.com/yesodweb/persistent/pull/996) * Added explicit `forall` notation to make most API functions play nice when using `TypeApplications`. (e.g. instead of `selectList @_ @_ @User [] []`, you can now write `selectList @User [] []`) [#1006](https://github.com/yesodweb/persistent/pull/1006) * [#1060](https://github.com/yesodweb/persistent/pull/1060) * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. * [#1044](https://github.com/yesodweb/persistent/pull/1044) * Field and constraint labels generated by TH can now be customized. * mpsPrefixFields is deprecated in favor of using these customisation functions. * [#1032](https://github.com/yesodweb/persistent/pull/1032) * Instance for `Natural` is removed. See `OverflowNatural` for a replacement and rationale on why. * [#1063](https://github.com/yesodweb/persistent/pull/1063) * A new class member `keyFromRecordM` allows you to construct a `Key record` from a `record` if it was defined with `Primary`. * [#1036](https://github.com/yesodweb/persistent/pull/1036) * The method `entityIdFromJSON` that is used to parse entities now correctly works for entities that define a custom `Primary` key. * [#856](https://github.com/yesodweb/persistent/pull/856) * Modify `upsertBy` to use backend-specific implementation (if any). * [#1066](https://github.com/yesodweb/persistent/pull/1066) * You can set a column's `sql=id` for a non `Id` column. * Fix a bug where unsafe migration error messages were being shown using `Show` prior to printing, resulting in less helpful output. [#1080](https://github.com/yesodweb/persistent/pull/1080) * [#1087](https://github.com/yesodweb/persistent/pull/1087) * `RawSql` now has tuple instances up to GHC's max tuple size (62) * [#1076](https://github.com/yesodweb/persistent/pull/1076) * `Loc` is now imported from `monad-logger` as opposed to `template-haskell`. Removes `template-haskell` as an explicit dependency. * [#1114](https://github.com/yesodweb/persistent/pull/1114) * Remove unnecessary deriving of `Typeable`. * [#1128](https://github.com/yesodweb/persistent/pull/1128) * Remove `Monad` constraint on `entityDef` * [#1127](https://github.com/yesodweb/persistent/pull/1127) * Remove deriving of `Show` for uniques. Users that need a `Show` instance can put a standalone deriving instance: ```haskell deriving stock instance Show (Unique User) ``` * [#1131](https://github.com/yesodweb/persistent/pull/1131) * Add an `exists` function to the `PersistQueryRead` type class. * [#1117](https://github.com/yesodweb/persistent/issues/1117) * Allow parsing UTCTimes from sqlite with the format "%F %T%Q" as well, instead of only "%FT%T%Q". * [#1140](https://github.com/yesodweb/persistent/pull/1140) * A new function `checkUniqueUpdateable` allows you to check uniqueness constraints on an entity update without having to update it. * [#1142](https://github.com/yesodweb/persistent/pull/1142) * Deprecate `hasCompositeKey` in favor of `hasCustomPrimaryKey` and `hasCompositePrimaryKey` functions. * [#1098](https://github.com/yesodweb/persistent/pull/1098) * Add support for configuring the number of stripes and idle timeout for connection pools * For functions that do not specify an idle timeout, the default has been bumped to 600 seconds. * This change is based off the experience of two production codebases. See [#775](https://github.com/yesodweb/persistent/issues/775) * Add a new type `ConnectionPoolConfig` to configure the number of connections in a pool, their idle timeout, and stripe size. * Add `defaultConnectionPoolConfig` to create a `ConnectionPoolConfig` * Add `createSqlPoolWithConfig` and `withSqlPoolWithConfig`, which take this new data type * [#1122](https://github.com/yesodweb/persistent/pull/1122), [#1152](https://github.com/yesodweb/persistent/pull/1152) * Adds a new constructor, `PersistLiteral ByteString` to `PersistValue` to support unescaped SQL literals. * Obviously, this is highly unsafe, and you should never use it with user input. * Adds a new field, `cGenerated :: Maybe Text` to `Column` for backend-specific support of generated columns. * Express generated fields in the Persistent DSL ```haskell GeneratedColumnExample fieldOne Text Maybe fieldTwo Text Maybe fieldThree Text Maybe generated=COALESCE(field_one,field_two) ``` * Support for MySQL >= 5.7. (No version checking is performed! Using this feature with older versions of MySQL will cause runtime SQL exceptions!) * Support for Postgresql >= 12. (No version checking is performed! Using this feature with older versions of Postgresql will cause runtime SQL exceptions!) * Support for SQLite >= 3.31 (same caveat applies; support added in #1152 ) * [#1151](https://github.com/yesodweb/persistent/pull/1151) * Allow `OverloadedLabels` to be used with the `EntityField` type. ## 2.10.5.2 * [#1041](https://github.com/yesodweb/persistent/pull/1041) * Explicit foreign keys can now reference tables with custom sql name * Add qualified names to the stock classes list. ## 2.10.5.1 * [#1024](https://github.com/yesodweb/persistent/pull/1024) * Add the ability to do documentation comments in entity definition syntax. Unfortunately, TemplateHaskell cannot add documentation comments, so this can't be used to add Haddocks to entities. * Add Haddock explainers for some of the supported entity syntax in `Database.Persist.Quasi` ## 2.10.5 * Add the `EntityWithPrefix` type to allow users to specify a custom prefix for raw SQL queries. [#1018](https://github.com/yesodweb/persistent/pull/1018) * Added Acquire based API to `Database.Persist.Sql` for working with connections/pools in monads which aren't MonadUnliftIO. [#984](https://github.com/yesodweb/persistent/pull/984) ## 2.10.4 * Log exceptions when closing a connection fails. See point 1 in [yesod #1635](https://github.com/yesodweb/yesod/issues/1635#issuecomment-547300856). [#978](https://github.com/yesodweb/persistent/pull/978) ## 2.10.3 * Added support for GHC 8.8 about MonadFail changes [#976](https://github.com/yesodweb/persistent/pull/976) ## 2.10.2 * Added `runMigrationQuiet` and `runMigrationUnsafeQuiet` to `Database.Persist.Sql.Migration` as safer alternatives to `runMigrationSilent`. [#971](https://github.com/yesodweb/persistent/pull/971) This functions as workaround/fix for: [#966](https://github.com/yesodweb/persistent/issues/966), [#948](https://github.com/yesodweb/persistent/issues/948), [#640](https://github.com/yesodweb/persistent/issues/640), and [#474](https://github.com/yesodweb/persistent/issues/474) * Added RawSql instances for 9, 10, 11 and 12-column results. [#961](https://github.com/yesodweb/persistent/pull/961) ## 2.10.1 * Added `constraint=` attribute to allow users to specify foreign reference constraint names. ## 2.10.0 * Added two type classes `OnlyOneUniqueKey` and `AtLeastOneUniqueKey`. These classes are used as constraints on functions that expect a certain amount of unique keys. They are defined automatically as part of the `persistent-template`'s generation. [#885](https://github.com/yesodweb/persistent/pull/885) * Add the `entityComments` field to the `EntityDef` datatype, and `fieldComments` fields to the `FieldDef` datatype. The QuasiQuoter does not currently know how to add documentation comments to these types, but it can be expanded later. [#865](https://github.com/yesodweb/persistent/pull/865) * Expose the `SqlReadT` and `SqlWriteT` constructors. [#887](https://github.com/yesodweb/persistent/pull/887) * Remove deprecated `Connection` type synonym. Please use `SqlBackend` instead. [#894](https://github.com/yesodweb/persistent/pull/894) * Remove deprecated `SqlPersist` type synonym. Please use `SqlPersistT` instead. [#894](https://github.com/yesodweb/persistent/pull/894) * Alter the type of `connUpsertSql` to take a list of unique definitions. This paves the way for more efficient upsert implementations. [#895](https://github.com/yesodweb/persistent/pull/895) ## 2.9.2 * Add documentation for the `Migration` type and some helpers. [#860](https://github.com/yesodweb/persistent/pull/860) ## 2.9.1 * Fix [#847](https://github.com/yesodweb/persistent/issues/847): SQL error with `putMany` on Sqlite when Entity has no unique index. ## 2.9.0 * Added support for SQL isolation levels to via SqlBackend. [#812] * Move `Database.Persist.Sql.Raw.QQ` to a separate `persistent-qq` package [#827](https://github.com/yesodweb/persistent/issues/827) * Fix [832](https://github.com/yesodweb/persistent/issues/832): `repsertMany` now matches `mapM_ (uncurry repsert)` and is atomic for supported sql back-ends. ## 2.8.2 * Added support for `sql=` to the unique constraints quasi-quoter so that users can specify the database names of the constraints. ## 2.8.1 * DRY-ed up and exposed several util functions in `Database.Persist.Sql.Util`. * Upstream-ed `updatePersistValue`, `mkUpdateText`, and `commaSeparated` from `Database.Persist.MySQL`. * De-duplicated `updatePersistValue` from various `Database.Persist.Sql.Orphan.*` modules. * Batching enhancements to reduce db round-trips. * Added `getMany` and `repsertMany` for batched `get` and `repsert`. * Added `putMany` with a default/slow implementation. SqlBackend's that support native UPSERT should override this for batching enhancements. * Updated `insertEntityMany` to replace slow looped usage with batched execution. * See [#770](https://github.com/yesodweb/persistent/pull/770) ## 2.8.0 * Switch from `MonadBaseControl` to `MonadUnliftIO` * Reapplies [#723](https://github.com/yesodweb/persistent/pull/723), which was reverted in version 2.7.3. ## 2.7.3.1 * Improve error messages when failing to parse database results into Persistent records. [#741](https://github.com/yesodweb/persistent/pull/741) * A handful of `fromPersistField` implementations called `error` instead of returning a `Left Text`. All of the implementations were changed to return `Left`. [#741](https://github.com/yesodweb/persistent/pull/741) * Improve error message when a SQL insert fails with a custom primary key [#757](https://github.com/yesodweb/persistent/pull/757) ## 2.7.3 * Reverts [#723](https://github.com/yesodweb/persistent/pull/723), which generalized functions using the `BackendCompatible` class. These changes were an accidental breaking change. * Recommend the `PersistDbSpecific` docs if someone gets an error about converting from `PersistDbSpecific` ## 2.7.2 [DEPRECATED ON HACKAGE] * Many of the functions have been generalized using the `BackendCompatible` class. [#723](https://github.com/yesodweb/persistent/pull/723) * This change was an accidental breaking change and was reverted in 2.7.3. * These change will be released in a future version of Persistent with a major version bump. * Add raw sql quasi quoters [#717](https://github.com/yesodweb/persistent/pull/717) ## 2.7.1 * Added an `insertUniqueEntity` function [#718](https://github.com/yesodweb/persistent/pull/718) * Added `BackendCompatible` class [#701](https://github.com/yesodweb/persistent/pull/701) ## 2.7.0 * Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613) * Atomic upsert query fixed for arithmatic operations [#662](https://github.com/yesodweb/persistent/issues/662) * Haddock and test coverage improved for upsert ## 2.6.1 * Fix edge case for `\<-. [Nothing]` * Introduce `connMaxParams` * Add 'getJustEntity' and 'insertRecord' convenience function * Minor Haddock improvment ## 2.6 * Add `connUpsertSql` type for providing backend-specific upsert sql support. ## 2.5 * read/write typeclass split * add insertOrGet convenience function to PersistUnique ## 2.2.4.1 * Documentation updates [#515](https://github.com/yesodweb/persistent/pull/515) ## 2.2.4 * Workaround for side-exiting transformers in `runSqlConn` [#516](https://github.com/yesodweb/persistent/issues/516) ## 2.2.3 * PersistField instance for Natural * better oracle support in odbc ## 2.2.2 * Add liftSqlPersistMPool function * support http-api-data for url serialization ## 2.2.1 * Migration failure message with context * Fix insertKey for composite keys ## 2.2 * Add a `RawSql` instance for `Key`. This allows selecting primary keys using functions like `rawSql`. [#407](https://github.com/yesodweb/persistent/pull/407) * SqlBackend support for an optimized `insertMany` ## 2.1.6 Important! If persistent-template is not upgraded to 2.1.3.3 you might need to make sure `Int64` is in scope for your model declarations. * add showMigration function * explicitly use Int64 for foreign key references ## 2.1.5 Add `dbIdColumnsEsc` to Sql.Utils. Used in persistent-postgresql 2.1.5.2 ## 2.1.4 * Fix getBy with a primary key. #342 ## 2.1.3 * Break self-referencing cycles in the entity declarations ## 2.1.2 * Error with `Double`s without a decimal part [#378](https://github.com/yesodweb/persistent/issues/378) * `runSqlPool` does not perform timeout checks. ## 2.1.1.6 * One extra feature for #939: use `logDebugN` instead ## 2.1.1.5 * Better SQL logging [Yesod issue #939](https://github.com/yesodweb/yesod/issues/939) ## 2.1.1.3 Parse UTCTime in 8601 format [#339](https://github.com/yesodweb/persistent/issues/339) ## 2.1.1.1 Support for monad-control 1.0 persistent-2.14.6.0/README.md0000644000000000000000000000032014476403105013606 0ustar0000000000000000## persistent Type-safe, data serialization. You must use a specific backend in order to make this useful. For more information, see [the chapter in the Yesod book](http://www.yesodweb.com/book/persistent). persistent-2.14.6.0/LICENSE0000644000000000000000000000207514476403105013345 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. persistent-2.14.6.0/Setup.lhs0000755000000000000000000000016214476403105014146 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain persistent-2.14.6.0/persistent.cabal0000644000000000000000000001611714507117603015526 0ustar0000000000000000name: persistent version: 2.14.6.0 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman , Greg Weber synopsis: Type-safe, multi-backend data serialization. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Database, Yesod stability: Stable cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md 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.22 , text >= 1.2 , th-lift-instances >= 0.1.14 && < 0.2 , time >= 1.6 , transformers >= 0.5 , unliftio , unliftio-core , unordered-containers , vault , vector default-extensions: FlexibleContexts , MultiParamTypeClasses , OverloadedStrings , TypeFamilies 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 Database.Persist.Quasi Database.Persist.Quasi.Internal Database.Persist.Sql Database.Persist.Sql.Migration Database.Persist.Sql.Types.Internal Database.Persist.Sql.Util 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 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.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 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 hs-source-dirs: test/ ghc-options: -Wall 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 default-language: Haskell2010 source-repository head type: git location: git://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