diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index 7f8fbdd..6f707f8 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -1041,7 +1041,7 @@ from parts = do runFrom :: From a -> SqlQuery (a, FromClause) runFrom e@Table = do let ed = entityDef $ getVal e - ident <- newIdentFor . DBName . unEntityNameDB $ entityDB ed + ident <- newIdentFor . DBName . unEntityNameDB $ getEntityDBName ed let entity = EEntity ident pure $ (entity, FromStart ident ed) where diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index d9b9cbf..1483860 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -15,6 +15,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + -- | This is an internal module, anything exported by this module -- may change without a major version bump. Please use only -- "Database.Esqueleto" if possible. @@ -23,6 +25,8 @@ -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL import Control.Applicative ((<|>)) import Control.Arrow (first, (***)) import Control.Exception (Exception, throw, throwIO) @@ -60,8 +64,8 @@ import qualified Database.Persist import Database.Persist (FieldNameDB(..), EntityNameDB(..)) import Database.Persist.Sql.Util ( entityColumnCount - , entityColumnNames - , hasCompositeKey + , keyAndEntityColumnNames + , hasNaturalKey , isIdField , parseEntityValues ) @@ -89,7 +93,7 @@ fromStart => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) fromStart = do let ed = entityDef (Proxy :: Proxy a) - ident <- newIdentFor (coerce $ entityDB ed) + ident <- newIdentFor (coerce $ getEntityDBName ed) let ret = EEntity ident f' = FromStart ident ed return (EPreprocessedFrom ret f') @@ -538,7 +542,7 @@ subSelectUnsafe = sub SELECT fieldDef = if isIdField field then -- TODO what about composite natural keys in a join this will ignore them - head $ entityKeyFields ed + NEL.head $ getEntityKeyFields ed else persistFieldDef field @@ -549,12 +553,12 @@ e ^. field | otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, []) where idFieldValue = - case entityKeyFields ed of - idField:[] -> + case getEntityKeyFields ed of + idField :| [] -> ERaw Never $ \info -> (dot info idField, []) idFields -> - ECompositeKey $ \info -> dot info <$> idFields + ECompositeKey $ \info -> NEL.toList $ dot info <$> idFields ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) @@ -1288,7 +1292,7 @@ toUniqueDef uniqueConstructor = uniqueDef unique = finalR uniqueConstructor -- there must be a better way to get the constrain name from a unique, make this not a list search filterF = (==) (persistUniqueToFieldNames unique) . uniqueFields - uniqueDef = head . filter filterF . entityUniques . entityDef $ proxy + uniqueDef = head . filter filterF . getEntityUniques . entityDef $ proxy -- | Render updates to be use in a SET clause for a given sql backend. -- @@ -2019,6 +2023,43 @@ type IdentInfo = (SqlBackend, IdentState) useIdent :: IdentInfo -> Ident -> TLB.Builder useIdent info (I ident) = fromDBName info $ DBName ident +entityAsValue + :: SqlExpr (Entity val) + -> SqlExpr (Value (Entity val)) +entityAsValue eent = + case eent of + EEntity ident -> + identToRaw ident + EAliasedEntity ident _ -> + identToRaw ident + EAliasedEntityReference _ ident -> + identToRaw ident + where + identToRaw ident = + ERaw Never $ \identInfo -> + ( useIdent identInfo ident + , [] + ) + +entityAsValueMaybe + :: SqlExpr (Maybe (Entity val)) + -> SqlExpr (Value (Maybe (Entity val))) +entityAsValueMaybe (EMaybe eent) = + case eent of + EEntity ident -> + identToRaw ident + EAliasedEntity ident _ -> + identToRaw ident + EAliasedEntityReference _ ident -> + identToRaw ident + where + identToRaw ident = + ERaw Never $ \identInfo -> + ( useIdent identInfo ident + , [] + ) + + -- | An expression on the SQL backend. -- -- There are many comments describing the constructors of this @@ -2906,7 +2947,7 @@ makeFrom info mode fs = ret (useIdent info ident, mempty) base ident@(I identText) def = - let db@(DBName dbText) = coerce $ entityDB def + let db@(DBName dbText) = coerce $ getEntityDBName def in ( fromDBName info db <> if dbText == identText then mempty @@ -3070,10 +3111,10 @@ instance SqlSelect (SqlExpr InsertFinal) InsertFinal where let fields = uncommas $ map (fromDBName info . coerce . fieldDB) $ - entityFields $ + getEntityFields $ entityDef p table = - fromDBName info . DBName . coerce . entityDB . entityDef $ p + fromDBName info . DBName . coerce . getEntityDBName . entityDef $ p in ("INSERT INTO " <> table <> parens fields <> "\n", []) sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info @@ -3089,16 +3130,26 @@ instance SqlSelect () () where unescapedColumnNames :: EntityDef -> [DBName] unescapedColumnNames ent = - (if hasCompositeKey ent then id else ( coerce (fieldDB (entityId ent)) :)) - $ map (coerce . fieldDB) (entityFields ent) + addIdColumn rest + where + rest = + map (coerce . fieldDB) (getEntityFields ent) + addIdColumn = + case getEntityId ent of + EntityIdField fd -> + (:) (coerce (fieldDB fd)) + EntityIdNaturalKey _ -> + id -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where sqlSelectCols info expr@(EEntity ident) = ret where - process ed = uncommas $ - map ((name <>) . TLB.fromText) $ - entityColumnNames ed (fst info) + process ed = + uncommas + $ map ((name <>) . TLB.fromText) + $ NEL.toList + $ keyAndEntityColumnNames ed (fst info) -- 'name' is the biggest difference between 'RawSql' and -- 'SqlSelect'. We automatically create names for tables -- (since it's not the user who's writing the FROM diff --git a/src/Database/Esqueleto/Internal/PersistentImport.hs b/src/Database/Esqueleto/Internal/PersistentImport.hs index 5a90c4f..d3c0d44 100644 --- a/src/Database/Esqueleto/Internal/PersistentImport.hs +++ b/src/Database/Esqueleto/Internal/PersistentImport.hs @@ -3,139 +3,142 @@ module Database.Esqueleto.Internal.PersistentImport -- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276 -- has been merged. See https://github.com/bitemyapp/esqueleto/issues/110 for more details - ( toJsonText, - entityIdFromJSON, - entityIdToJSON, - entityValues, - fromPersistValueJSON, - keyValueEntityFromJSON, - keyValueEntityToJSON, - toPersistValueJSON, - selectKeys, - belongsTo, - belongsToJust, - getEntity, - getJust, - getJustEntity, - insertEntity, - insertRecord, - liftPersist, - checkUnique, - getByValue, - insertBy, - insertUniqueEntity, - onlyUnique, - replaceUnique, - transactionSave, - transactionUndo, - defaultAttribute, - mkColumns, - getMigration, - migrate, - parseMigration, - parseMigration', - printMigration, - runMigration, - runMigrationSilent, - runMigrationUnsafe, - showMigration, - decorateSQLWithLimitOffset, - fieldDBName, - fromSqlKey, - getFieldName, - getTableName, - tableDBName, - toSqlKey, - withRawQuery, - getStmtConn, - rawExecute, - rawExecuteCount, - rawQuery, - rawQueryRes, - rawSql, - close', - createSqlPool, - liftSqlPersistMPool, - runSqlConn, - runSqlPersistM, - runSqlPersistMPool, - runSqlPool, - withSqlConn, - withSqlPool, - readToUnknown, - readToWrite, - writeToUnknown, - entityKeyFields, - entityPrimary, - fromPersistValueText, - keyAndEntityFields, - toEmbedEntityDef, - PersistStore, - PersistUnique, - DeleteCascade(..), - PersistConfig(..), - BackendSpecificUpdate, - Entity(..), - PersistEntity(..), - PersistField(..), - SomePersistField(..), - PersistQueryRead(..), - PersistQueryWrite(..), - BackendCompatible(..), - BackendKey(..), - HasPersistBackend(..), - IsPersistBackend, - PersistCore(..), - PersistRecordBackend, - PersistStoreRead(..), - PersistStoreWrite(..), - ToBackendKey(..), - PersistUniqueRead(..), - PersistUniqueWrite(..), - PersistFieldSql(..), - RawSql(..), - CautiousMigration, - Column(..), - ConnectionPool, - Migration, - PersistentSqlException(..), - Single(..), - Sql, - SqlPersistM, - SqlPersistT, - InsertSqlResult(..), - IsSqlBackend, - LogFunc, - SqlBackend(..), - SqlBackendCanRead, - SqlBackendCanWrite, - SqlReadBackend(..), - SqlReadT, - SqlWriteBackend(..), - SqlWriteT, - Statement(..), - Attr, - Checkmark(..), - CompositeDef(..), - EmbedEntityDef(..), - EmbedFieldDef(..), - EntityDef(..), - ExtraLine, - FieldDef(..), - FieldType(..), - ForeignDef(..), - ForeignFieldDef, - IsNullable(..), - OnlyUniqueException(..), - PersistException(..), - PersistFilter(..), - PersistUpdate(..), - PersistValue(..), - ReferenceDef(..), - SqlType(..), - UniqueDef(..), - UpdateException(..), - WhyNullable(..) + ( toJsonText + , entityIdFromJSON + , entityIdToJSON + , entityValues + , fromPersistValueJSON + , keyValueEntityFromJSON + , keyValueEntityToJSON + , toPersistValueJSON + , selectKeys + , belongsTo + , belongsToJust + , getEntity + , getJust + , getJustEntity + , insertEntity + , insertRecord + , liftPersist + , checkUnique + , getByValue + , insertBy + , insertUniqueEntity + , onlyUnique + , replaceUnique + , transactionSave + , transactionUndo + , defaultAttribute + , mkColumns + , getMigration + , migrate + , parseMigration + , parseMigration' + , printMigration + , runMigration + , runMigrationSilent + , runMigrationUnsafe + , showMigration + , decorateSQLWithLimitOffset + , fieldDBName + , fromSqlKey + , getFieldName + , getTableName + , tableDBName + , toSqlKey + , withRawQuery + , getStmtConn + , rawExecute + , rawExecuteCount + , rawQuery + , rawQueryRes + , rawSql + , close' + , createSqlPool + , liftSqlPersistMPool + , runSqlConn + , runSqlPersistM + , runSqlPersistMPool + , runSqlPool + , withSqlConn + , withSqlPool + , readToUnknown + , readToWrite + , writeToUnknown + , getEntityKeyFields + , entityPrimary + , keyAndEntityFields + , PersistStore + , PersistUnique + , DeleteCascade(..) + , PersistConfig(..) + , BackendSpecificUpdate + , Entity(..) + , PersistEntity(..) + , PersistField(..) + , SomePersistField(..) + , PersistQueryRead(..) + , PersistQueryWrite(..) + , BackendCompatible(..) + , BackendKey(..) + , HasPersistBackend(..) + , IsPersistBackend + , PersistCore(..) + , PersistRecordBackend + , PersistStoreRead(..) + , PersistStoreWrite(..) + , ToBackendKey(..) + , PersistUniqueRead(..) + , PersistUniqueWrite(..) + , PersistFieldSql(..) + , RawSql(..) + , CautiousMigration + , Column(..) + , ConnectionPool + , Migration + , PersistentSqlException(..) + , Single(..) + , Sql + , SqlPersistM + , SqlPersistT + , InsertSqlResult(..) + , IsSqlBackend + , LogFunc + , SqlBackend + , SqlBackendCanRead + , SqlBackendCanWrite + , SqlReadBackend(..) + , SqlReadT + , SqlWriteBackend(..) + , SqlWriteT + , Statement(..) + , Attr + , Checkmark(..) + , CompositeDef(..) + , EmbedEntityDef(..) + , EmbedFieldDef(..) + , EntityDef + , EntityIdDef(..) + , ExtraLine + , FieldDef(..) + , FieldType(..) + , ForeignDef(..) + , ForeignFieldDef + , IsNullable(..) + , PersistException(..) + , PersistFilter(..) + , PersistUpdate(..) + , PersistValue(..) + , ReferenceDef(..) + , SqlType(..) + , UniqueDef(..) + , UpdateException(..) + , WhyNullable(..) + , getEntityFields + , getEntityId + , getEntityDBName + , getEntityUniques + , getEntityDBName ) where import Database.Persist.Sql hiding @@ -148,6 +151,7 @@ import Database.Persist.Sql hiding , delete , deleteCascadeWhere , deleteWhereCount + , exists , getPersistMap , limitOffsetOrder , listToJSON @@ -171,5 +175,4 @@ import Database.Persist.Sql hiding , (>.) , (>=.) , (||.) - , exists ) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index ce4ab3a..94e4a30 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -220,7 +220,7 @@ upsertBy uniqueKey record updates = do entDef = entityDef (Just record) updatesText conn = first builderToText $ renderUpdates conn updates #if MIN_VERSION_persistent(2,11,0) - uniqueFields = NonEmpty.fromList (persistUniqueToFieldNames uniqueKey) + uniqueFields = persistUniqueToFieldNames uniqueKey handler sqlB upsertSql = do let (updateText, updateVals) = updatesText sqlB @@ -308,7 +308,7 @@ insertSelectWithConflictCount unique query conflictQuery = do updates = conflictQuery entCurrent entExcluded combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) entExcluded = EEntity $ I "excluded" - tableName = unEntityNameDB . entityDB . entityDef + tableName = unEntityNameDB . getEntityDBName . entityDef entCurrent = EEntity $ I (tableName proxy) uniqueDef = toUniqueDef unique constraint = TLB.fromText . unConstraintNameDB . uniqueDBName $ uniqueDef diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 22362ec..8f9a75b 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -5,8 +5,9 @@ packages: - 'examples' extra-deps: +- lift-type-0.1.0.1 - git: git@github.com:yesodweb/persistent - commit: f7ad9b05a1ee899c6800962cbc795b39d01c5643 + commit: 315ae91349ef4fbc2f4f2595cb7d3423e79ef80f subdirs: - persistent - persistent-sqlite diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 1c9d77f..ecf7b11 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,4 +1,6 @@ -resolver: nightly-2020-09-20 +resolver: nightly-2021-05-05 packages: - '.' - 'examples' + + diff --git a/stack-nightly.yaml.lock b/stack-nightly.yaml.lock index afb31ae..228d81b 100644 --- a/stack-nightly.yaml.lock +++ b/stack-nightly.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 467884 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/24.yaml - sha256: 55c1a4fc9222bc3b8cf91461f38e2641da675a7296f06528f47340c19d0c6e85 - original: nightly-2020-01-24 + size: 581922 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/5/5.yaml + sha256: 70797737e072284037792abaffd399e029da7ec3c855fd27b16898662f285d82 + original: nightly-2021-05-05