Support OverloadedRecordDot (#310)

* Support OverloadedRecordDot

* stylish

* Haddocks

* Add comments to README

README.md

@@ -127,7 +127,61 @@ FROM Person
 WHERE Person.age >= 18
 ```
 
-Since `age` is an optional `Person` field, we use `just` to lift`val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`.
+Since `age` is an optional `Person` field, we use `just` to lift `val 18 :: SqlExpr (Value Int)` into `just (val 18) ::SqlExpr (Value (Maybe Int))`.
+
+### Alternative Field Projections
+
+The `(^.)` operator works on an `EntityField` value, which are generated by
+`persistent` as the table name + the field name. This can get a little bit
+verbose. As of `persistent-2.11`, you can use `OverloadedLabels` to make this a
+bit more concise:
+
+```haskell
+{-# LANGUAGE OverloadedLabels #-}
+
+select $ do
+    p <- from $ table @Person
+    pure
+        ( p ^. PersonName
+        , p ^. #name
+        )
+```
+
+The `OverloadedLabels` support uses the `fieldName` as given by the Persistent
+entity definition syntax - no type name prefix necessary. Additionally, these
+field accesses are *polymorphic* - the following query filters any table that
+has a `name` column:
+
+```haskell
+rowsByName
+    :: forall rec.
+    ( PersistEntity rec
+    , PersistEntityBackend rec ~ SqlBackend
+    , SymbolToField "name" rec Text
+    )
+    => SqlExpr (Value Text)
+    -> SqlQuery (SqlExpr (Entity rec))
+rowsByName name = do
+    rec <- from $ table @rec
+    where_ $ rec ^. #name ==. name
+    pure rec
+```
+
+GHC 9.2 introduces the `OverloadedRecordDot` language extension, and `esqueleto`
+supports this on `SqlExpr (Entity rec)` and `SqlExpr (Maybe (Entity rec))`. It
+looks like this:
+
+```haskell
+select $ do
+    (person, blogPost) <-
+        from $
+            table @Person
+            `leftJoin` table @BlogPost
+            `on` do
+                \(person :& blogPost) ->
+                    just person.id ==. blogPost.authorId
+    pure (person.name, blogPost.title)
+```
 
 ## Experimental/New Joins
 

changelog.md

@@ -1,3 +1,12 @@
+3.5.4.0
+=======
+- @parsonsmatt
+    - [#310](https://github.com/bitemyapp/esqueleto/pull/310)
+        - Add instances of `HasField` for `SqlExpr (Entity rec)` and `SqlExpr
+          (Maybe (Entity rec))`. These instances allow you to use the
+          `OverloadedRecordDot` language extension in GHC 9.2 with SQL
+          representations of database entities.
+
 3.5.3.2
 =======
 - @parsonsmatt

esqueleto.cabal

@@ -1,7 +1,7 @@
 cabal-version: 1.12
 
 name:           esqueleto
-version:        3.5.3.2
+version:        3.5.4.0
 synopsis:       Type-safe EDSL for SQL queries on persistent backends.
 description:    @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends.  Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime.
                 .

src/Database/Esqueleto/Internal/Internal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeApplications #-}
 {-# language DerivingStrategies, GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
@@ -61,7 +62,7 @@ import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr)
 import Database.Esqueleto.Internal.PersistentImport
 import Database.Persist.SqlBackend
 import qualified Database.Persist
-import Database.Persist (FieldNameDB(..), EntityNameDB(..))
+import Database.Persist (FieldNameDB(..), EntityNameDB(..), SymbolToField(..))
 import Database.Persist.Sql.Util
        ( entityColumnCount
        , keyAndEntityColumnNames
@@ -71,6 +72,7 @@ import Database.Persist.Sql.Util
 import Text.Blaze.Html (Html)
 import Data.Coerce (coerce)
 import Data.Kind (Type)
+import GHC.Records
 
 -- | (Internal) Start a 'from' query with an entity. 'from'
 -- does two kinds of magic using 'fromStart', 'fromJoin' and
@@ -2086,6 +2088,87 @@ entityAsValueMaybe = coerce
 -- interpolated by the SQL backend.
 data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
 
+-- |  This instance allows you to use @record.field@ notation with GHC 9.2's
+-- @OverloadedRecordDot@ extension.
+--
+-- Example:
+--
+-- @
+-- -- persistent model:
+-- BlogPost
+--     authorId     PersonId
+--     title        Text
+--
+-- -- query:
+-- 'select' $ do
+--     bp <- 'from' $ 'table' \@BlogPost
+--     pure $ bp.title
+-- @
+--
+-- This is exactly equivalent to the following:
+--
+-- @
+-- blogPost :: SqlExpr (Entity BlogPost)
+--
+-- blogPost ^. BlogPostTitle
+-- blogPost ^. #title
+-- blogPost.title
+-- @
+-- There's another instance defined on @'SqlExpr' ('Entity' ('Maybe' rec))@,
+-- which allows you to project from a @LEFT JOIN@ed entity.
+--
+-- @since 3.5.4.0
+instance
+    (PersistEntity rec, PersistField typ, SymbolToField sym rec typ)
+  =>
+    HasField sym (SqlExpr (Entity rec)) (SqlExpr (Value typ))
+  where
+    getField expr = expr ^. symbolToField @sym
+
+-- | This instance allows you to use @record.field@ notation with GC 9.2's
+-- @OverloadedRecordDot@ extension.
+--
+-- Example:
+--
+-- @
+-- -- persistent model:
+-- Person
+--     name         Text
+--
+-- BlogPost
+--     title        Text
+--     authorId     PersonId
+--
+-- -- query:
+--
+-- 'select' $ do
+--     (p :& bp) <- 'from' $
+--         'table' @Person
+--         `leftJoin` table @BlogPost
+--         `on` do
+--             \\(p :& bp) ->
+--                 just p.id ==. bp.authorId
+--     pure (p.name, bp.title)
+-- @
+--
+-- The following forms are all equivalent:
+--
+-- @
+-- blogPost :: SqlExpr (Maybe (Entity BlogPost))
+--
+-- blogPost ?. BlogPostTitle
+-- blogPost ?. #title
+-- blogPost.title
+-- @
+--
+-- @since 3.5.4.0
+instance
+    (PersistEntity rec, PersistField typ, SymbolToField sym rec typ)
+  =>
+    HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ)))
+  where
+    getField expr = expr ?. symbolToField @sym
+
 -- | Data type to support from hack
 data PreprocessedFrom a = PreprocessedFrom a FromClause
 

test/Common/Test.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -21,6 +20,11 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+
+#if __GLASGOW_HASKELL__ >= 902
+{-# LANGUAGE OverloadedRecordDot #-}
+#endif
 
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
@@ -66,9 +70,9 @@ module Common.Test
 import Common.Test.Import hiding (from, on)
 
 import Control.Monad (forM_, replicateM, replicateM_, void)
-import Data.Either
 import qualified Data.Attoparsec.Text as AP
 import Data.Char (toLower, toUpper)
+import Data.Either
 import Data.Monoid ((<>))
 import Database.Esqueleto
 import qualified Database.Esqueleto.Experimental as Experimental
@@ -2347,6 +2351,7 @@ tests =
         testOnClauseOrder
         testExperimentalFrom
         testLocking
+        testOverloadedRecordDot
 
 insert' :: ( Functor m
            , BaseBackend backend ~ PersistEntityBackend val
@@ -2441,3 +2446,27 @@ shouldBeOnClauseWithoutMatchingJoinException ea =
             pure ()
         _ ->
             expectationFailure $ "Expected OnClauseWithMatchingJoinException, got: " <> show ea
+
+testOverloadedRecordDot :: SpecDb
+testOverloadedRecordDot = describe "OverloadedRecordDot" $ do
+#if __GLASGOW_HASKELL__ >= 902
+    describe "with SqlExpr (Entity rec)" $ do
+        itDb "lets you project from a record" $ do
+            select $ do
+                bp <- Experimental.from $ table @BlogPost
+                pure bp.title
+    describe "with SqlExpr (Maybe (Entity rec))" $ do
+        itDb "lets you project from a Maybe record" $ do
+            select $ do
+                p :& mbp <- Experimental.from $
+                    table @Person
+                    `leftJoin` table @BlogPost
+                        `Experimental.on` do
+                            \(p :& mbp) ->
+                                just p.id ==. mbp.authorId
+                pure (p.id, mbp.title)
+
+#else
+    it "is only supported in GHC 9.2 or above" $ \_ -> do
+        pending
+#endif