esqueleto 3.5.5.0 → 3.5.6.1

raw patch · 12 files changed

+715/−153 lines, 12 filesdep +template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• changelog.md +11/−0
• esqueleto.cabal +5/−1
• src/Database/Esqueleto/Experimental/From.hs +0/−2
• src/Database/Esqueleto/Experimental/From/CommonTableExpression.hs +7/−0
• src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +1/−0
• src/Database/Esqueleto/Internal/Internal.hs +17/−1
• src/Database/Esqueleto/Internal/PersistentImport.hs +1/−142
• src/Database/Esqueleto/PostgreSQL.hs +3/−6
• src/Database/Esqueleto/Record.hs +511/−0
• test/Common/Record.hs +146/−0
• test/Common/Test.hs +2/−1
• test/Common/Test/Models.hs +11/−0

@@ -1,3 +1,14 @@+3.5.6.1+=======+- @9999years+    - [#324](https://github.com/bitemyapp/esqueleto/pull/324)+        - Add ability to use nested records with `deriveEsqueletoRecord`++3.5.6.0+=======+- @9999years+    - [#323](https://github.com/bitemyapp/esqueleto/pull/323)+        - Add ability to derive esqueleto instances for records  3.5.5.0 =======

@@ -2,7 +2,7 @@  name:           esqueleto -version:        3.5.5.0+version:        3.5.6.1 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.                 .@@ -37,6 +37,7 @@         Database.Esqueleto.MySQL         Database.Esqueleto.PostgreSQL         Database.Esqueleto.PostgreSQL.JSON+        Database.Esqueleto.Record         Database.Esqueleto.SQLite         Database.Esqueleto.Experimental.From         Database.Esqueleto.Experimental.From.CommonTableExpression@@ -63,6 +64,7 @@       , persistent >=2.13 && <3       , resourcet >=1.2       , tagged >=0.2+      , template-haskell       , text >=0.11 && <1.3       , time >=1.5.0.1 && <=1.13       , transformers >=0.2@@ -88,6 +90,7 @@         Common.Test.Models         Common.Test.Import         Common.Test.Select+        Common.Record         PostgreSQL.MigrateJSON         SQLite.Test         PostgreSQL.Test@@ -121,6 +124,7 @@       , QuickCheck       , resourcet       , tagged+      , template-haskell       , text       , time       , transformers

@@ -27,8 +27,6 @@ import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) import Database.Esqueleto.Internal.PersistentImport -import Database.Persist.Names (EntityNameDB(..))- -- | 'FROM' clause, used to bring entities into scope. -- -- Internally, this function uses the `From` datatype.

@@ -33,6 +33,13 @@ -- always verify that using a CTE will in fact improve your performance -- over a regular subquery. --+-- Notably, in PostgreSQL prior to version 12, CTEs are always fully+-- calculated, which can potentially significantly pessimize queries. As of+-- PostgreSQL 12, non-recursive and side-effect-free queries may be inlined and+-- optimized accordingly if not declared @MATERIALIZED@ to get the previous+-- behaviour. See [the PostgreSQL CTE documentation](https://www.postgresql.org/docs/current/queries-with.html#id-1.5.6.12.7),+-- section Materialization, for more information.+-- -- /Since: 3.4.0.0/ with :: ( ToAlias a         , ToAliasReference a

@@ -126,5 +126,6 @@ intersect_ = mkSetOperation " INTERSECT "  {-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-}+pattern SelectQuery :: p -> p pattern SelectQuery a = a 

@@ -62,7 +62,6 @@ import Database.Esqueleto.Internal.PersistentImport import Database.Persist.SqlBackend import qualified Database.Persist-import Database.Persist (FieldNameDB(..), EntityNameDB(..), SymbolToField(..)) import Database.Persist.Sql.Util        ( entityColumnCount        , keyAndEntityColumnNames@@ -1801,8 +1800,25 @@             "(FromRaw _)"        where+        -- We just want to use this to render expressions for a `Show` instance+        -- so we leave most of the fields undefined. But we explicitly+        -- initialize them to `undefined` so that GHC doesn't complain.         dummy = mkSqlBackend MkSqlBackendArgs             { connEscapeRawName = id+            , connPrepare = undefined+            , connInsertSql = undefined+            , connStmtMap = undefined+            , connClose = undefined+            , connMigrateSql = undefined+            , connBegin = undefined+            , connCommit = undefined+            , connRollback = undefined+            , connEscapeFieldName  = undefined+            , connEscapeTableName = undefined+            , connNoLimit = undefined+            , connRDBMS = undefined+            , connLimitOffset = undefined+            , connLogFunc = undefined             }         render' = T.unpack . renderExpr dummy 

@@ -3,147 +3,7 @@ -- | Re-export "Database.Persist.Sql" without any clashes with -- @esqueleto@. 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-    , getEntityKeyFields-    , entityPrimary-    , keyAndEntityFields-    , PersistStore-    , PersistUnique-    , PersistConfig(..)-    , BackendSpecificUpdate-    , Entity(..)-    , PersistEntity(..)-    , PersistField(..)-#if MIN_VERSION_persistent(2,14,0)-#else-    , DeleteCascade(..)-    , SomePersistField(..)-#endif-    , 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-    ) where+    (module Database.Persist.Sql) where  import Database.Persist.Sql hiding        ( BackendSpecificFilter@@ -153,7 +13,6 @@        , Update(..)        , count        , delete-       , deleteCascadeWhere        , deleteWhereCount        , exists        , getPersistMap

@@ -49,11 +49,8 @@ import qualified Data.Text.Lazy as TL import Data.Time.Clock (UTCTime) import qualified Database.Esqueleto.Experimental as Ex-import qualified Database.Esqueleto.Experimental.From as Ex import Database.Esqueleto.Internal.Internal hiding (random_)-import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)-import Database.Persist.Class (OnlyOneUniqueKey)-import Database.Persist (ConstraintNameDB(..), EntityNameDB(..))+import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy, uniqueFields) import Database.Persist.SqlBackend  -- | (@random()@) Split out into database specific modules@@ -328,9 +325,9 @@       ] ++ if null updates then [TLB.fromText "NOTHING"] else [         TLB.fromText "UPDATE SET ",         updatesTLB-      ]),values)+      ]),values')       where-        (updatesTLB,values) = renderedUpdates conn+        (updatesTLB,values') = renderedUpdates conn  -- | Allow aggregate functions to take a filter clause. --

@@ -0,0 +1,511 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Database.Esqueleto.Record+  ( deriveEsqueletoRecord+  ) where++import Control.Monad.Trans.State.Strict (StateT(..), evalStateT)+import Data.Proxy (Proxy(..))+import Database.Esqueleto.Experimental+       (Entity, PersistValue, SqlExpr, Value(..), (:&)(..))+import Database.Esqueleto.Internal.Internal (SqlSelect(..))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Data.Bifunctor (first)+import Data.Text (Text)+import Control.Monad (forM)+import Data.Foldable (foldl')+import GHC.Exts (IsString(fromString))+import Data.Maybe (mapMaybe, fromMaybe, listToMaybe)++-- | Takes the name of a Haskell record type and creates a variant of that+-- record prefixed with @Sql@ which can be used in esqueleto expressions. This+-- reduces the amount of pattern matching on large tuples required to interact+-- with data extracted with esqueleto.+--+-- Note that because the input record and the @Sql@-prefixed record share field+-- names, the @{-# LANGUAGE DuplicateRecordFields #-}@ extension is required in+-- modules that use `deriveEsqueletoRecord`. Additionally, the @{-# LANGUAGE+-- TypeApplications #-}@ extension is required for some of the generated code.+--+-- Given the following record:+--+-- @+-- data MyRecord = MyRecord+--   { myName    :: 'Text'+--   , myAge     :: 'Maybe' 'Int'+--   , myUser    :: 'Entity' User+--   , myAddress :: 'Maybe' ('Entity' Address)+--   }+-- @+--+-- @$('deriveEsqueletoRecord' ''MyRecord)@ will generate roughly the following code:+--+-- @+-- data SqlMyRecord =+--   SqlMyRecord { myName    :: 'SqlExpr' ('Value' Text)+--               , myAge     :: 'SqlExpr' ('Value' Int)+--               , myUser    :: 'SqlExpr' ('Entity' User)+--               , myAddress :: 'SqlExpr' ('Maybe' ('Entity' Address))+--               }+--+-- instance 'SqlSelect' SqlMyRecord MyRecord where+--   'sqlSelectCols'+--     identInfo+--     SqlMyRecord { myName    = myName+--                 , myAge     = myAge+--                 , myUser    = myUser+--                 , myAddress = myAddress+--                 } =+--     'sqlSelectCols' identInfo (myName :& myAge :& myUser :& myAddress)+--+--   'sqlSelectColCount' _ =+--     'sqlSelectColCount'+--       ('Proxy' \@(   ('SqlExpr' ('Value' Text))+--                :& ('SqlExpr' ('Value' Int))+--                :& ('SqlExpr' ('Entity' User))+--                :& ('SqlExpr' ('Maybe' ('Entity' Address)))))+--+--   'sqlSelectProcessRow' columns =+--     'first' (('fromString' "Failed to parse MyRecord: ") <>)+--           ('evalStateT' process columns)+--     where+--       process = do+--         'Value' myName <- 'takeColumns' \@('SqlExpr' ('Value' Text))+--         'Value' myAge  <- 'takeColumns' \@('SqlExpr' ('Value' Int))+--         myUser       <- 'takeColumns' \@('SqlExpr' ('Entity' User))+--         myAddress    <- 'takeColumns' \@('SqlExpr' ('Maybe' ('Entity' Address)))+--         'pure' MyRecord { myName = myName+--                       , myAge = myAge+--                       , myUser = myUser+--                       , myAddress = myAddress+--                       }+-- @+--+-- Then, we could write a selection function to use the record in queries:+--+-- @+-- getMyRecord :: 'Database.Esqueleto.SqlPersistT' 'IO' [MyRecord]+-- getMyRecord = 'Database.Esqueleto.Experimental.select' myRecordQuery+--+-- myRecordQuery :: 'Database.Esqueleto.SqlQuery' SqlMyRecord+-- myRecordQuery = do+--   user ':&' address <- 'Database.Esqueleto.Experimental.from' '$'+--     'Database.Esqueleto.Experimental.table' \@User+--       \`'Database.Esqueleto.Experimental.leftJoin'\`+--       'Database.Esqueleto.Experimental.table' \@Address+--       \`'Database.Esqueleto.Experimental.on'\` (do \\(user ':&' address) -> user 'Database.Esqueleto.Experimental.^.' #address 'Database.Esqueleto.Experimental.==.' address 'Database.Esqueleto.Experimental.?.' #id)+--   'pure'+--     SqlMyRecord+--       { myName = 'Database.Esqueleto.Experimental.castString' '$' user 'Database.Esqueleto.Experimental.^.' #firstName+--       , myAge = 'Database.Esqueleto.Experimental.val' 10+--       , myUser = user+--       , myAddress = address+--       }+-- @+--+-- @since 3.5.6.0+deriveEsqueletoRecord :: Name -> Q [Dec]+deriveEsqueletoRecord originalName = do+  info <- getRecordInfo originalName+  -- It would be nicer to use `mconcat` here but I don't think the right+  -- instance is available in GHC 8.+  recordDec <- makeSqlRecord info+  instanceDec <- makeSqlSelectInstance info+  pure+    [ recordDec+    , instanceDec+    ]++-- | Information about a record we need to generate the declarations.+-- We compute this once and then pass it around to save on complexity /+-- repeated work.+data RecordInfo = RecordInfo+  { -- | The original record's name.+    name :: Name+  , -- | The generated @Sql@-prefixed record's name.+    sqlName :: Name+  , -- | The original record's constraints. If this isn't empty it'll probably+    -- cause problems, but it's easy to pass around so might as well.+    constraints :: Cxt+  , -- | The original record's type-variable-binders.+#if MIN_VERSION_template_haskell(2,17,0)+    typeVarBinders :: [TyVarBndr ()]+#else+    typeVarBinders :: [TyVarBndr]+#endif+  , -- | The original record's kind, I think.+    kind :: Maybe Kind+  , -- | The original record's constructor name.+    constructorName :: Name+  , -- | The original record's field names and types, derived from the+    -- constructors.+    fields :: [(Name, Type)]+  , -- | The generated @Sql@-prefixed record's field names and types, computed+    -- with 'sqlFieldType'.+    sqlFields :: [(Name, Type)]+  }++-- | Get a `RecordInfo` instance for the given record name.+getRecordInfo :: Name -> Q RecordInfo+getRecordInfo name = do+  TyConI dec <- reify name+  (constraints, typeVarBinders, kind, constructors) <-+        case dec of+          DataD constraints' _name typeVarBinders' kind' constructors' _derivingClauses ->+            pure (constraints', typeVarBinders', kind', constructors')+          NewtypeD constraints' _name typeVarBinders' kind' constructor' _derivingClauses ->+            pure (constraints', typeVarBinders', kind', [constructor'])+          _ -> fail $ "Esqueleto records can only be derived for records and newtypes, but " ++ show name ++ " is neither"+  constructor <- case constructors of+                  (c : _) -> pure c+                  [] -> fail $ "Cannot derive Esqueleto record for a type with no constructors: " ++ show name+  let constructorName =+        case head constructors of+          RecC name' _fields -> name'+          con -> error $ nonRecordConstructorMessage con+      fields = getFields constructor+      sqlName = makeSqlName name++  sqlFields <- mapM toSqlField fields++  pure RecordInfo {..}+  where+    getFields :: Con -> [(Name, Type)]+    getFields (RecC _name fields) = [(fieldName', fieldType') | (fieldName', _bang, fieldType') <- fields]+    getFields con = error $ nonRecordConstructorMessage con++    toSqlField (fieldName', ty) = do+      sqlTy <- sqlFieldType ty+      pure (fieldName', sqlTy)++-- | Create a new name by prefixing @Sql@ to a given name.+makeSqlName :: Name -> Name+makeSqlName name = mkName $ "Sql" ++ nameBase name++-- | Transforms a record field type into a corresponding `SqlExpr` type.+--+-- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@.+-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@.+-- * @x@ is transformed into @'SqlExpr' ('Value' x)@.+-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@.+--+-- This function should match `sqlSelectProcessRowPat`.+sqlFieldType :: Type -> Q Type+sqlFieldType fieldType = do+  maybeSqlType <- reifySqlSelectType fieldType++  pure $+    flip fromMaybe maybeSqlType $+      case fieldType of+        -- Entity x -> SqlExpr (Entity x)+        AppT (ConT ((==) ''Entity -> True)) _innerType -> AppT (ConT ''SqlExpr) fieldType++        -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x))+        (ConT ((==) ''Maybe -> True))+          `AppT` ((ConT ((==) ''Entity -> True))+                  `AppT` _innerType) -> AppT (ConT ''SqlExpr) fieldType++        -- x -> SqlExpr (Value x)+        _ -> (ConT ''SqlExpr)+                `AppT` ((ConT ''Value)+                        `AppT` fieldType)++-- | Generates the declaration for an @Sql@-prefixed record, given the original+-- record's information.+makeSqlRecord :: RecordInfo -> Q Dec+makeSqlRecord RecordInfo {..} = do+  let newConstructor = RecC (makeSqlName constructorName) (makeField `map` sqlFields)+      derivingClauses = []+  pure $ DataD constraints sqlName typeVarBinders kind [newConstructor] derivingClauses+  where+    makeField (fieldName', fieldType) =+      (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType)++-- | Generates an `SqlSelect` instance for the given record and its+-- @Sql@-prefixed variant.+makeSqlSelectInstance :: RecordInfo -> Q Dec+makeSqlSelectInstance info@RecordInfo {..} = do+  sqlSelectColsDec' <- sqlSelectColsDec info+  sqlSelectColCountDec' <- sqlSelectColCountDec info+  sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info+  let overlap = Nothing+      instanceConstraints = []+      instanceType =+        (ConT ''SqlSelect)+          `AppT` (ConT sqlName)+          `AppT` (ConT name)++  pure $ InstanceD overlap instanceConstraints instanceType [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec']++-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.+sqlSelectColsDec :: RecordInfo -> Q Dec+sqlSelectColsDec RecordInfo {..} = do+  -- Pairs of record field names and local variable names.+  fieldNames <- forM sqlFields (\(name', _type) -> do+    var <- newName $ nameBase name'+    pure (name', var))++  -- Patterns binding record fields to local variables.+  let fieldPatterns :: [FieldPat]+      fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames]++      -- Local variables for fields joined with `:&` in a single expression.+      joinedFields :: Exp+      joinedFields =+        case snd `map` fieldNames of+          [] -> TupE []+          [f1] -> VarE f1+          f1 : rest ->+            let helper lhs field =+                  InfixE+                    (Just lhs)+                    (ConE '(:&))+                    (Just $ VarE field)+             in foldl' helper (VarE f1) rest++  identInfo <- newName "identInfo"+  -- Roughly:+  -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields+  pure $+    FunD+      'sqlSelectCols+      [ Clause+          [ VarP identInfo+          , RecP sqlName fieldPatterns+          ]+          ( NormalB $+              (VarE 'sqlSelectCols)+                `AppE` (VarE identInfo)+                `AppE` (ParensE joinedFields)+          )+          -- `where` clause.+          []+      ]++-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance.+sqlSelectColCountDec :: RecordInfo -> Q Dec+sqlSelectColCountDec RecordInfo {..} = do+  let joinedTypes =+        case snd `map` sqlFields of+          [] -> TupleT 0+          t1 : rest ->+            let helper lhs ty =+                  InfixT lhs ''(:&) ty+             in foldl' helper t1 rest++  -- Roughly:+  -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes))+  pure $+    FunD+      'sqlSelectColCount+      [ Clause+          [WildP]+          ( NormalB $+              AppE (VarE 'sqlSelectColCount) $+                ParensE $+                  AppTypeE+                    (ConE 'Proxy)+                    joinedTypes+          )+          -- `where` clause.+          []+      ]++-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`+-- instance.+sqlSelectProcessRowDec :: RecordInfo -> Q Dec+sqlSelectProcessRowDec RecordInfo {..} = do+  -- Binding statements and field expressions (used in record construction) to+  -- fill out the body of the main generated `do` expression.+  --+  -- Each statement is like:+  --     Value fooName' <- takeColumns @(SqlExpr (Value Text))+  -- A corresponding field expression would be:+  --     fooName = fooName'+  --+  -- See `sqlSelectProcessRowPat` for the left-hand side of the patterns.+  (statements, fieldExps) <-+    unzip <$> forM (zip fields sqlFields) (\((fieldName', fieldType), (_, sqlType')) -> do+      valueName <- newName (nameBase fieldName')+      pattern <- sqlSelectProcessRowPat fieldType valueName+      pure+        ( BindS+            pattern+            (AppTypeE (VarE 'takeColumns) sqlType')+        , (mkName $ nameBase fieldName', VarE valueName)+        ))++  colsName <- newName "columns"+  processName <- newName "process"++  -- Roughly:+  -- sqlSelectProcessRow $colsName =+  --   first ((fromString "Failed to parse $name: ") <>)+  --         (evalStateT $processName $colsName)+  --   where $processName = do $statements+  --                           pure $name {$fieldExps}+  bodyExp <- [e|+    first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>)+          (evalStateT $(varE processName) $(varE colsName))+    |]++  pure $+    FunD+      'sqlSelectProcessRow+      [ Clause+          [VarP colsName]+          (NormalB bodyExp)+          -- `where` clause+          [ ValD+              (VarP processName)+              ( NormalB $+                  DoE+#if MIN_VERSION_template_haskell(2,17,0)+                    Nothing+#endif+                    (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE constructorName fieldExps)])+              )+              []+          ]+      ]++-- | Get the left-hand side pattern of a statement in a @do@ block for binding+-- to the result of `sqlSelectProcessRow`.+--+-- * A type of @'Entity' x@ gives a pattern of @var@.+-- * A type of @'Maybe' ('Entity' x)@ gives a pattern of @var@.+-- * A type of @x@ gives a pattern of @'Value' var@.+-- * If there exists an instance @'SqlSelect' sql x@, then a type of @x@ gives a pattern of @var@.+--+-- This function should match `sqlFieldType`.+sqlSelectProcessRowPat :: Type -> Name -> Q Pat+sqlSelectProcessRowPat fieldType var = do+  maybeSqlType <- reifySqlSelectType fieldType++  case maybeSqlType of+    Just _ -> pure $ VarP var+    Nothing -> case fieldType of+        -- Entity x -> var+        AppT (ConT ((==) ''Entity -> True)) _innerType -> pure $ VarP var+        -- Maybe (Entity x) -> var+        (ConT ((==) ''Maybe -> True))+          `AppT` ((ConT ((==) ''Entity -> True))+                  `AppT` _innerType) -> pure $ VarP var+        -- x -> Value var+#if MIN_VERSION_template_haskell(2,18,0)+        _ -> pure $ ConP 'Value [] [VarP var]+#else+        _ -> pure $ ConP 'Value [VarP var]+#endif++-- Given a type, find the corresponding SQL type.+--+-- If there exists an instance `SqlSelect sql ty`, then the SQL type for `ty`+-- is `sql`.+--+-- This function definitely works for records and instances generated by this+-- module, and might work for instances outside of it.+reifySqlSelectType :: Type -> Q (Maybe Type)+reifySqlSelectType originalType = do+  -- Here we query the compiler for Instances of `SqlSelect a $(originalType)`;+  -- the API for this is super weird, it interprets a list of types as being+  -- applied as successive arguments to the typeclass name.+  --+  -- See: https://gitlab.haskell.org/ghc/ghc/-/issues/21825+  --+  -- >>> reifyInstances ''SqlSelect [VarT (mkName "a"), ConT ''MyRecord]+  -- [ InstanceD Nothing+  --             []+  --             (AppT (AppT (ConT Database.Esqueleto.Internal.Internal.SqlSelect)+  --                         (ConT Ghci3.SqlMyRecord))+  --                   (ConT Ghci3.MyRecord))+  --             []+  -- ]+  tyVarName <- newName "a"+  instances <- reifyInstances ''SqlSelect [VarT tyVarName, originalType]++  -- Given the original type (`originalType`) and an instance type for a+  -- `SqlSelect` instance, get the SQL type which corresponds to the original+  -- type.+  let extractSqlRecord :: Type -> Type -> Maybe Type+      extractSqlRecord originalTy instanceTy =+        case instanceTy of+          (ConT ((==) ''SqlSelect -> True))+            `AppT` sqlTy+            `AppT` ((==) originalTy -> True) -> Just sqlTy+          _ -> Nothing++      -- Filter `instances` to the instances which match `originalType`.+      filteredInstances :: [Type]+      filteredInstances =+        flip mapMaybe instances+          (\case InstanceD _overlap+                           _constraints+                           (extractSqlRecord originalType -> Just sqlRecord)+                           _decs ->+                             Just sqlRecord+                 _ -> Nothing)++  pure $ listToMaybe filteredInstances++-- | Statefully parse some number of columns from a list of `PersistValue`s,+-- where the number of columns to parse is determined by `sqlSelectColCount`+-- for @a@.+--+-- This is used to implement `sqlSelectProcessRow` for records created with+-- `deriveEsqueletoRecord`.+takeColumns ::+  forall a b.+  SqlSelect a b =>+  StateT [PersistValue] (Either Text) b+takeColumns = StateT (\pvs ->+  let targetColCount =+        sqlSelectColCount (Proxy @a)+      (target, other) =+        splitAt targetColCount pvs+   in if length target == targetColCount+        then do+          value <- sqlSelectProcessRow target+          Right (value, other)+        else Left "Insufficient columns when trying to parse a column")++-- | Get an error message for a non-record constructor.+-- This module does not yet support non-record constructors, so we'll tell the+-- user what sort of constructor they provided that we can't use, along with+-- the name of that constructor. This turns out to require recursion, but you+-- can't win every battle.+nonRecordConstructorMessage :: Con -> String+nonRecordConstructorMessage con =+  case con of+    (RecC {}) -> error "Record constructors are not an error"+    (NormalC {}) -> helper "non-record data constructor"+    (InfixC {}) -> helper "infix constructor"+    (ForallC {}) -> helper "constructor qualified by type variables / class contexts"+    (GadtC {}) -> helper "GADT constructor"+    (RecGadtC {}) -> helper "record GADT constructor"+  where+    helper constructorType =+      "Esqueleto records can only be derived for record constructors, but "+        ++ show (constructorName con)+        ++ " is a "+        ++ constructorType++    constructorName constructor =+      case constructor of+        (RecC name _) -> name+        (NormalC name _fields) -> name+        (InfixC _ty1 name _ty2) -> name+        (ForallC _vars _constraints innerConstructor) -> constructorName innerConstructor+        -- If there's GADTs where multiple constructors are declared with the+        -- same type signature you're evil and furthermore this diagnostic will+        -- only show you the first name.+        (GadtC names _fields _ret) -> head names+        (RecGadtC names _fields _ret) -> head names

@@ -0,0 +1,146 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- Tests for `Database.Esqueleto.Record`.+module Common.Record (testDeriveEsqueletoRecord) where++import Common.Test.Import hiding (from, on)+import Data.List (sortOn)+import Database.Esqueleto.Experimental+import Database.Esqueleto.Record (deriveEsqueletoRecord)++data MyRecord =+    MyRecord+        { myName :: Text+        , myAge :: Maybe Int+        , myUser :: Entity User+        , myAddress :: Maybe (Entity Address)+        }+  deriving (Show, Eq)++$(deriveEsqueletoRecord ''MyRecord)++myRecordQuery :: SqlQuery SqlMyRecord+myRecordQuery = do+  user :& address <- from $+    table @User+      `leftJoin`+      table @Address+      `on` (do \(user :& address) -> user ^. #address ==. address ?. #id)+  pure+    SqlMyRecord+      { myName = castString $ user ^. #name+      , myAge = val $ Just 10+      , myUser = user+      , myAddress = address+      }++data MyNestedRecord = MyNestedRecord+  { myName :: Text+  , myRecord :: MyRecord+  }+  deriving (Show, Eq)++$(deriveEsqueletoRecord ''MyNestedRecord)++myNestedRecordQuery :: SqlQuery SqlMyNestedRecord+myNestedRecordQuery = do+  user :& address <-+    from $+      table @User+        `leftJoin` table @Address+        `on` (do \(user :& address) -> user ^. #address ==. address ?. #id)+  pure+    SqlMyNestedRecord+      { myName = castString $ user ^. #name+      , myRecord =+          SqlMyRecord+            { myName = castString $ user ^. #name+            , myAge = val $ Just 10+            , myUser = user+            , myAddress = address+            }+      }++testDeriveEsqueletoRecord :: SpecDb+testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do+    let setup :: MonadIO m => SqlPersistT m ()+        setup = do+          _ <- insert $ User { userAddress = Nothing, userName = "Rebecca" }+          addr <- insert $ Address { addressAddress = "30-50 Feral Hogs Rd" }+          _ <- insert $ User { userAddress = Just addr, userName = "Some Guy" }+          pure ()++    itDb "can select records" $ do+        setup+        records <- select myRecordQuery+        let sortedRecords = sortOn (\MyRecord {myName} -> myName) records+        liftIO $ sortedRecords !! 0+          `shouldSatisfy`+          (\case MyRecord { myName = "Rebecca"+                          , myAge = Just 10+                          , myUser = Entity _ User { userAddress  = Nothing+                                                   , userName = "Rebecca"+                                                   }+                          , myAddress = Nothing+                          } -> True+                 _ -> False)+        liftIO $ sortedRecords !! 1+          `shouldSatisfy`+          (\case MyRecord { myName = "Some Guy"+                          , myAge = Just 10+                          , myUser = Entity _ User { userAddress  = Just addr1+                                                   , userName = "Some Guy"+                                                   }+                          , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+                          } -> addr1 == addr2 -- The keys should match.+                 _ -> False)++    itDb "can select nested records" $ do+        setup+        records <- select myNestedRecordQuery+        let sortedRecords = sortOn (\MyNestedRecord {myName} -> myName) records+        liftIO $ sortedRecords !! 0+          `shouldSatisfy`+          (\case MyNestedRecord+                   { myName = "Rebecca"+                   , myRecord =+                       MyRecord { myName = "Rebecca"+                                , myAge = Just 10+                                , myUser = Entity _ User { userAddress  = Nothing+                                                         , userName = "Rebecca"+                                                         }+                                , myAddress = Nothing+                                }+                   } -> True+                 _ -> False)++        liftIO $ sortedRecords !! 1+          `shouldSatisfy`+          (\case MyNestedRecord+                   { myName = "Some Guy"+                   , myRecord =+                       MyRecord { myName = "Some Guy"+                                , myAge = Just 10+                                , myUser = Entity _ User { userAddress  = Just addr1+                                                         , userName = "Some Guy"+                                                         }+                                , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})+                                }+                   } -> addr1 == addr2 -- The keys should match.+                 _ -> False)

@@ -73,7 +73,6 @@ 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 @@ -90,6 +89,7 @@ import Database.Persist.Class.PersistEntity  import Common.Test.Select+import Common.Record (testDeriveEsqueletoRecord)  -- Test schema -- | this could be achieved with S.fromList, but not all lists@@ -2353,6 +2353,7 @@         testExperimentalFrom         testLocking         testOverloadedRecordDot+        testDeriveEsqueletoRecord  insert' :: ( Functor m            , BaseBackend backend ~ PersistEntityBackend val

@@ -171,6 +171,17 @@   DateTruncTest     created   UTCTime     deriving Eq Show++  User+    address AddressId Maybe+    name String+    deriving Show+    deriving Eq++  Address+    address String+    deriving Show+    deriving Eq |]  -- Unique Test schema