From e18dd125c5ea26fa4e88bed079b61d8c1365ee37 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 31 Mar 2022 09:14:48 -0600 Subject: [PATCH] Support OverloadedRecordDot (#310) * Support OverloadedRecordDot * stylish * Haddocks * Add comments to README --- README.md | 56 +++++++++++++- changelog.md | 9 +++ esqueleto.cabal | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 85 ++++++++++++++++++++- test/Common/Test.hs | 33 +++++++- 5 files changed, 180 insertions(+), 5 deletions(-) diff --git a/README.md b/README.md index 479bfa6..fc347f1 100644 --- a/README.md +++ b/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 diff --git a/changelog.md b/changelog.md index 9029c16..dc7874e 100644 --- a/changelog.md +++ b/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 diff --git a/esqueleto.cabal b/esqueleto.cabal index 7a6248b..1692a03 100644 --- a/esqueleto.cabal +++ b/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. . diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index c3c4966..2533772 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/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 diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 9928fcd..1a8df9e 100644 --- a/test/Common/Test.hs +++ b/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