work with persistent-2.13

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

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
+       , keyAndEntityColumnNames
-       , hasCompositeKey
+       , 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
+        case getEntityKeyFields ed of
-            idField:[] ->
+            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)) :))
+    addIdColumn rest
-    $ map (coerce . fieldDB) (entityFields ent)
+  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 $
+        process ed =
-                     map ((name <>) . TLB.fromText) $
+            uncommas
-                     entityColumnNames ed (fst info)
+            $ 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

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,
+    ( toJsonText
-    entityIdFromJSON,
+    , entityIdFromJSON
-    entityIdToJSON,
+    , entityIdToJSON
-    entityValues,
+    , entityValues
-    fromPersistValueJSON,
+    , fromPersistValueJSON
-    keyValueEntityFromJSON,
+    , keyValueEntityFromJSON
-    keyValueEntityToJSON,
+    , keyValueEntityToJSON
-    toPersistValueJSON,
+    , toPersistValueJSON
-    selectKeys,
+    , selectKeys
-    belongsTo,
+    , belongsTo
-    belongsToJust,
+    , belongsToJust
-    getEntity,
+    , getEntity
-    getJust,
+    , getJust
-    getJustEntity,
+    , getJustEntity
-    insertEntity,
+    , insertEntity
-    insertRecord,
+    , insertRecord
-    liftPersist,
+    , liftPersist
-    checkUnique,
+    , checkUnique
-    getByValue,
+    , getByValue
-    insertBy,
+    , insertBy
-    insertUniqueEntity,
+    , insertUniqueEntity
-    onlyUnique,
+    , onlyUnique
-    replaceUnique,
+    , replaceUnique
-    transactionSave,
+    , transactionSave
-    transactionUndo,
+    , transactionUndo
-    defaultAttribute,
+    , defaultAttribute
-    mkColumns,
+    , mkColumns
-    getMigration,
+    , getMigration
-    migrate,
+    , migrate
-    parseMigration,
+    , parseMigration
-    parseMigration',
+    , parseMigration'
-    printMigration,
+    , printMigration
-    runMigration,
+    , runMigration
-    runMigrationSilent,
+    , runMigrationSilent
-    runMigrationUnsafe,
+    , runMigrationUnsafe
-    showMigration,
+    , showMigration
-    decorateSQLWithLimitOffset,
+    , decorateSQLWithLimitOffset
-    fieldDBName,
+    , fieldDBName
-    fromSqlKey,
+    , fromSqlKey
-    getFieldName,
+    , getFieldName
-    getTableName,
+    , getTableName
-    tableDBName,
+    , tableDBName
-    toSqlKey,
+    , toSqlKey
-    withRawQuery,
+    , withRawQuery
-    getStmtConn,
+    , getStmtConn
-    rawExecute,
+    , rawExecute
-    rawExecuteCount,
+    , rawExecuteCount
-    rawQuery,
+    , rawQuery
-    rawQueryRes,
+    , rawQueryRes
-    rawSql,
+    , rawSql
-    close',
+    , close'
-    createSqlPool,
+    , createSqlPool
-    liftSqlPersistMPool,
+    , liftSqlPersistMPool
-    runSqlConn,
+    , runSqlConn
-    runSqlPersistM,
+    , runSqlPersistM
-    runSqlPersistMPool,
+    , runSqlPersistMPool
-    runSqlPool,
+    , runSqlPool
-    withSqlConn,
+    , withSqlConn
-    withSqlPool,
+    , withSqlPool
-    readToUnknown,
+    , readToUnknown
-    readToWrite,
+    , readToWrite
-    writeToUnknown,
+    , writeToUnknown
-    entityKeyFields,
+    , getEntityKeyFields
-    entityPrimary,
+    , entityPrimary
-    fromPersistValueText,
+    , keyAndEntityFields
-    keyAndEntityFields,
+    , PersistStore
-    toEmbedEntityDef,
+    , PersistUnique
-    PersistStore,
+    , DeleteCascade(..)
-    PersistUnique,
+    , PersistConfig(..)
-    DeleteCascade(..),
+    , BackendSpecificUpdate
-    PersistConfig(..),
+    , Entity(..)
-    BackendSpecificUpdate,
+    , PersistEntity(..)
-    Entity(..),
+    , PersistField(..)
-    PersistEntity(..),
+    , SomePersistField(..)
-    PersistField(..),
+    , PersistQueryRead(..)
-    SomePersistField(..),
+    , PersistQueryWrite(..)
-    PersistQueryRead(..),
+    , BackendCompatible(..)
-    PersistQueryWrite(..),
+    , BackendKey(..)
-    BackendCompatible(..),
+    , HasPersistBackend(..)
-    BackendKey(..),
+    , IsPersistBackend
-    HasPersistBackend(..),
+    , PersistCore(..)
-    IsPersistBackend,
+    , PersistRecordBackend
-    PersistCore(..),
+    , PersistStoreRead(..)
-    PersistRecordBackend,
+    , PersistStoreWrite(..)
-    PersistStoreRead(..),
+    , ToBackendKey(..)
-    PersistStoreWrite(..),
+    , PersistUniqueRead(..)
-    ToBackendKey(..),
+    , PersistUniqueWrite(..)
-    PersistUniqueRead(..),
+    , PersistFieldSql(..)
-    PersistUniqueWrite(..),
+    , RawSql(..)
-    PersistFieldSql(..),
+    , CautiousMigration
-    RawSql(..),
+    , Column(..)
-    CautiousMigration,
+    , ConnectionPool
-    Column(..),
+    , Migration
-    ConnectionPool,
+    , PersistentSqlException(..)
-    Migration,
+    , Single(..)
-    PersistentSqlException(..),
+    , Sql
-    Single(..),
+    , SqlPersistM
-    Sql,
+    , SqlPersistT
-    SqlPersistM,
+    , InsertSqlResult(..)
-    SqlPersistT,
+    , IsSqlBackend
-    InsertSqlResult(..),
+    , LogFunc
-    IsSqlBackend,
+    , SqlBackend
-    LogFunc,
+    , SqlBackendCanRead
-    SqlBackend(..),
+    , SqlBackendCanWrite
-    SqlBackendCanRead,
+    , SqlReadBackend(..)
-    SqlBackendCanWrite,
+    , SqlReadT
-    SqlReadBackend(..),
+    , SqlWriteBackend(..)
-    SqlReadT,
+    , SqlWriteT
-    SqlWriteBackend(..),
+    , Statement(..)
-    SqlWriteT,
+    , Attr
-    Statement(..),
+    , Checkmark(..)
-    Attr,
+    , CompositeDef(..)
-    Checkmark(..),
+    , EmbedEntityDef(..)
-    CompositeDef(..),
+    , EmbedFieldDef(..)
-    EmbedEntityDef(..),
+    , EntityDef
-    EmbedFieldDef(..),
+    , EntityIdDef(..)
-    EntityDef(..),
+    , ExtraLine
-    ExtraLine,
+    , FieldDef(..)
-    FieldDef(..),
+    , FieldType(..)
-    FieldType(..),
+    , ForeignDef(..)
-    ForeignDef(..),
+    , ForeignFieldDef
-    ForeignFieldDef,
+    , IsNullable(..)
-    IsNullable(..),
+    , PersistException(..)
-    OnlyUniqueException(..),
+    , PersistFilter(..)
-    PersistException(..),
+    , PersistUpdate(..)
-    PersistFilter(..),
+    , PersistValue(..)
-    PersistUpdate(..),
+    , ReferenceDef(..)
-    PersistValue(..),
+    , SqlType(..)
-    ReferenceDef(..),
+    , UniqueDef(..)
-    SqlType(..),
+    , UpdateException(..)
-    UniqueDef(..),
+    , WhyNullable(..)
-    UpdateException(..),
+    , getEntityFields
-    WhyNullable(..)
+    , 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
        )

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

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

stack-nightly.yaml

@@ -1,4 +1,6 @@
-resolver: nightly-2020-09-20
+resolver: nightly-2021-05-05
 packages:
   - '.'
   - 'examples'
+
+

stack-nightly.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 467884
+    size: 581922
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/1/24.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2021/5/5.yaml
-    sha256: 55c1a4fc9222bc3b8cf91461f38e2641da675a7296f06528f47340c19d0c6e85
+    sha256: 70797737e072284037792abaffd399e029da7ec3c855fd27b16898662f285d82
-  original: nightly-2020-01-24
+  original: nightly-2021-05-05