Provide HasField instances for Entity for OverloadedRecordDot (#…

…1381) * lmaooo * remove commentary * k * sigh * Changelog
yesodweb · Apr 12, 2022 · 6c8afab · 6c8afab
1 parent a06c207
commit 6c8afab
Show file tree

Hide file tree

Showing 5 changed files with 35 additions and 15 deletions.
diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -578,7 +578,7 @@ instance PersistStoreWrite DB.MongoContext where
         either err instantiate result
       where
         instantiate doc = do
-            Entity _ rec <- fromPersistValuesThrow t doc
+            rec <- entityVal <$> fromPersistValuesThrow t doc
             return rec
         err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg
         t = entityDefFromKey key
@@ -589,7 +589,7 @@ instance PersistStoreRead DB.MongoContext where
             case d of
               Nothing -> return Nothing
               Just doc -> do
-                Entity _ ent <- fromPersistValuesThrow t doc
+                ent <- entityVal <$> fromPersistValuesThrow t doc
                 return $ Just ent
           where
             t = entityDefFromKey k

diff --git a/persistent-redis/Database/Persist/Redis/Store.hs b/persistent-redis/Database/Persist/Redis/Store.hs
@@ -57,8 +57,8 @@ instance PersistStoreRead R.Connection where
         if null r
             then return Nothing
             else do
-                Entity _ val <- liftIO $ mkEntity k r
-                return $ Just val
+                entity <- liftIO $ mkEntity k r
+                return $ Just (entityVal entity)
 
 instance PersistStoreWrite R.Connection where
     insert val = do
@@ -98,7 +98,7 @@ instance PersistStoreWrite R.Connection where
             then pure ()
             else do
                 v <- liftIO $ mkEntity k r
-                let (Entity _ val) = cmdUpdate v upds
+                let val = entityVal $ cmdUpdate v upds
                 insertKey k val
         return()
 

diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -3,6 +3,14 @@
 
 ## 2.14.0.0 (unreleased)
 
+* [#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.

diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# language PatternSynonyms #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE GADTs #-}
@@ -21,7 +22,7 @@ module Database.Persist.Class.PersistEntity
     , Filter (..)
     , FilterValue (..)
     , BackendSpecificFilter
-    , Entity (..)
+    , Entity (.., Entity, entityKey, entityVal)
 
     , recordName
     , entityValues
@@ -34,6 +35,8 @@ module Database.Persist.Class.PersistEntity
     , SymbolToField (..)
     ) where
 
+import Data.Functor.Constant
+
 import Data.Aeson
        ( FromJSON(..)
        , ToJSON(..)
@@ -56,6 +59,7 @@ import qualified Data.Aeson.KeyMap as AM
 import qualified Data.HashMap.Strict as AM
 #endif
 
+import GHC.Records
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (isJust)
 import Data.Text (Text)
@@ -303,15 +307,29 @@ data FilterValue typ where
 -- Entity backend b)@), then you must you use @SELECT ??, ??
 -- WHERE ...@, and so on.
 data Entity record =
-    Entity { entityKey :: Key record
-           , entityVal :: record }
+    Entity' (Key record) record
+
+pattern Entity :: Key rec -> rec -> Entity rec
+pattern Entity { entityKey,  entityVal } = Entity' entityKey entityVal
+
+{-# COMPLETE Entity #-}
 
 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)
 
+instance
+    ( SymbolToField sym ent typ
+    , PersistEntity ent
+    )
+  =>
+    HasField sym (Entity ent) typ
+  where
+    getField ent =
+        getConstant ((fieldLens (symbolToField @sym @ent @typ)) Constant ent)
+
 -- | Get list of values corresponding to given entity.
 entityValues :: PersistEntity record => Entity record -> [PersistValue]
 entityValues (Entity k record) =

diff --git a/stack-nightly.yaml b/stack-nightly.yaml
@@ -1,4 +1,4 @@
-resolver: lts-14.1
+resolver: nightly-2022-04-05
 packages:
   - ./persistent
   - ./persistent-sqlite
@@ -8,9 +8,3 @@ packages:
   - ./persistent-postgresql
   - ./persistent-redis
   - ./persistent-qq
-
-extra-deps:
-  - bson-0.3.2.8
-  - hedis-0.12.8
-  - HTTP-4000.3.14
-  - th-lift-instances-0.1.14