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
-       , 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

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
        )

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
-    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