packages feed

poppy (empty) → 1.0.0

raw patch · 93 files changed

+12134/−0 lines, 93 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, directory, filepath, hspec, mtl, poppy, postgresql-simple, process, resource-pool, scientific, text, time, uuid

Files

+ CHANGELOG.md view
@@ -0,0 +1,30 @@+# Changelog++All notable changes to `poppy` are documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++Released in **lockstep** with `poppy-codegen`. See the [repository changelog](../CHANGELOG.md)+for the full 1.0 contract, 1.1 plans, and non-goals.++## 1.0.0 — 2026-10-09++Stable Postgres runtime for Schema-generated Clients.++- Public API is `Poppy` only. Generated Clients import `Poppy.Internal.Generated`.+  Low-level `findMany` / builders / `Db (..)` are no longer re-exported from `Poppy`.+- Haddock on Client-facing exports. Guides: repository `docs/`.+- `--check-schema` / pool helpers: shipped code reads `DATABASE_URL` only; tests use+  `TEST_DATABASE_URL`.+- Remove `Poppy.JoinChain` and `Poppy.Relation`. Ad-hoc joins are raw SQL.+- `load` and `loadWith` take `where_`, `orderBy_`, and `take_`. Include result types+  follow the include shape (`skip` / `load` / `loadWith`).+- Nested writes are fields on `create` / `update`. `createNested` / `updateNested` are gone.+  Write success values remain root `*Row` values.+- `updateWhere` updates by a `Where`. `findUniqueWhere`, `requireUniqueWhere`, and+  `InvalidUniqueInput` are gone.++## 0.1.0.0 — 2026-09-17++First release. Runtime for Schema-generated Clients: queries, writes, `Db`, and Postgres errors.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023–2026 Henrik Nerdrum++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Henrik Nerdrum nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# poppy++The runtime library for [Poppy](https://github.com/hnerdrum/poppy), a Postgres ORM for Haskell. Your app imports `poppy` to query and write through the client that [`poppy-codegen`](https://github.com/hnerdrum/poppy/tree/main/poppy-codegen) generates from your schema. It also provides `applyMigrations`, which runs your hand-written `.sql` migrations before the app starts.++The [repository README](https://github.com/hnerdrum/poppy#readme) shows the full setup, and the [guides](https://github.com/hnerdrum/poppy/tree/main/docs) cover the client API, writes, relations, raw SQL, and errors.
+ include-fail/RecordUpdateAmbiguous.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}++module RecordUpdateAmbiguous where++import Poppy (load, skip)+import Schema.Include.Book (BookInclude (..))++data Other = Other {chapters :: Int}++updated =+  nested {chapters = load}+  where+    nested = BookInclude {chapters = skip}
+ include-fail/SkippedChapters.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}++module SkippedChapters where++import Poppy.Internal.Include (Skip)+import Schema.Chapter (ChapterRow)+import Schema.Include.Book (BookWith (..))++bad :: BookWith Skip -> [ChapterRow]+bad row = row.chapters
+ include-fail/SkippedChaptersNoSelectors.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoFieldSelectors #-}++module SkippedChaptersNoSelectors where++import Poppy.Internal.Include (Skip)+import Schema.Chapter (ChapterRow)+import Schema.Include.Book (BookWith (..))++bad :: BookWith Skip -> [ChapterRow]+bad row = row.chapters
+ include-fail/WrongChild.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DuplicateRecordFields #-}++module WrongChild where++import Poppy (loadWith, skip)+import qualified Schema.Client.Shelf as Shelf+import Schema.Include.Shelf (ShelfInclude (..))++bad =+  Shelf.findMany+    Shelf.emptyQuery+      { Shelf.include_ =+          ShelfInclude+            { books = loadWith (ShelfInclude {books = skip, tags = skip}),+              tags = skip+            }+      }
+ poppy.cabal view
@@ -0,0 +1,185 @@+cabal-version: 1.18++-- This file has been generated from package.yaml by hpack version 0.38.3.+--+-- see: https://github.com/sol/hpack++name:           poppy+version:        1.0.0+synopsis:       Postgres runtime for generated Poppy Clients+description:    Runtime used by Clients generated by poppy-codegen.+                Application code imports this package to query and write Postgres.+category:       Database+stability:      stable+homepage:       https://github.com/hnerdrum/poppy#readme+bug-reports:    https://github.com/hnerdrum/poppy/issues+author:         Henrik Nerdrum+maintainer:     henrik.nerdrum@gmail.com+copyright:      2023–2026 Henrik Nerdrum+license:        BSD3+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.4.8, GHC == 9.10.3+extra-source-files:+    test/migrations/001-test-widget.sql+    test/migrations/002-test-shelf-book.sql+    test/migrations/003-test-chapter.sql+    test/migrations/004-test-section.sql+    test/migrations/005-test-tag.sql+    test/migrations/006-test-author-post.sql+    test/migrations/007-test-packet.sql+    test/migrations/008-test-comment.sql+    test/migrations/009-test-widget-name-unique.sql+    include-fail/RecordUpdateAmbiguous.hs+    include-fail/SkippedChapters.hs+    include-fail/SkippedChaptersNoSelectors.hs+    include-fail/WrongChild.hs+    unique-fail/NonUniqueFilter.hs+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/hnerdrum/poppy++library+  exposed-modules:+      Poppy+      Poppy.Internal.Generated+      Poppy.Internal.Column+      Poppy.Internal.Core+      Poppy.Internal.Db+      Poppy.Internal.Delete+      Poppy.Internal.Errors+      Poppy.Internal.Group+      Poppy.Internal.Include+      Poppy.Internal.Insert+      Poppy.Internal.Migrate+      Poppy.Internal.Operations+      Poppy.Internal.PG+      Poppy.Internal.Query+      Poppy.Internal.Select+      Poppy.Internal.SelectIn+      Poppy.Internal.Sql+      Poppy.Internal.Update+      Poppy.Internal.Where+  other-modules:+      Paths_poppy+  hs-source-dirs:+      src+  default-extensions:+      DuplicateRecordFields+      NamedFieldPuns+      OverloadedRecordDot+      OverloadedStrings+      TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=2.0 && <2.3+    , base >=4.17 && <4.21+    , bytestring >=0.11 && <0.13+    , containers >=0.6 && <0.8+    , directory ==1.3.*+    , filepath >=1.4 && <1.6+    , mtl >=2.2 && <2.4+    , postgresql-simple >=0.6 && <0.8+    , resource-pool ==0.4.*+    , scientific >=0.3.4 && <0.4+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , uuid ==1.3.*+  default-language: Haskell2010++test-suite poppy-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Poppy.AuthorFixtures+      Poppy.BelongsToSpec+      Poppy.ClientWriteSpec+      Poppy.CommentSpec+      Poppy.DbSpec+      Poppy.EnumSpec+      Poppy.ErrorsSpec+      Poppy.GroupSpec+      Poppy.IncludeFailSpec+      Poppy.IncludeSpec+      Poppy.IncludeUpdate+      Poppy.MigrateSpec+      Poppy.NestedWriteSpec+      Poppy.OperationsSpec+      Poppy.RawSpec+      Poppy.ScalarSpec+      Poppy.SelectSpec+      Poppy.ShelfFixtures+      Poppy.UniqueFailSpec+      Poppy.WhereSpec+      Poppy.WidgetFixtures+      Schema.Article+      Schema.Author+      Schema.Book+      Schema.Chapter+      Schema.Client.Article+      Schema.Client.Author+      Schema.Client.Book+      Schema.Client.Chapter+      Schema.Client.Comment+      Schema.Client.Editor+      Schema.Client.Post+      Schema.Client.Section+      Schema.Client.Shelf+      Schema.Client.Tag+      Schema.Client.Widget+      Schema.Comment+      Schema.Editor+      Schema.Include.Author+      Schema.Include.Book+      Schema.Include.Chapter+      Schema.Include.Comment+      Schema.Include.Editor+      Schema.Include.Post+      Schema.Include.Shelf+      Schema.Packet+      Schema.Post+      Schema.PostStatus+      Schema.Section+      Schema.Shelf+      Schema.Tag+      Schema.Widget+      Support.Assert+      Support.TestDb+      Support.TestMigrations+      Paths_poppy+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      DuplicateRecordFields+      LambdaCase+      NamedFieldPuns+      OverloadedRecordDot+      OverloadedStrings+      ScopedTypeVariables+      TypeApplications+      TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson >=2.0 && <2.3+    , base >=4.17 && <4.21+    , bytestring >=0.11 && <0.13+    , containers >=0.6 && <0.8+    , directory ==1.3.*+    , filepath >=1.4 && <1.6+    , hspec >=2.11 && <2.13+    , mtl >=2.2 && <2.4+    , poppy+    , postgresql-simple >=0.6 && <0.8+    , process ==1.6.*+    , resource-pool ==0.4.*+    , scientific >=0.3.4 && <0.4+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , uuid ==1.3.*+  default-language: Haskell2010
+ src/Poppy.hs view
@@ -0,0 +1,107 @@+-- | Runtime used by generated Poppy Clients.+--+-- Application code typically imports this module plus @Schema.Client.*@.+-- Guides: the repository @docs/@ directory. This module is the Haddock+-- entry point for @Db@, @ORMError@, query combinators, and @applyMigrations@.+--+-- Generated @Schema.*@ modules import 'Poppy.Internal.Generated' instead.+module Poppy+  ( -- * Connection+    Db,+    DbPool,+    PoolConfig (..),+    SqlLogger,+    connect,+    connectWith,+    defaultPool,+    closePool,+    runDb,+    transaction,+    transactionEither,+    withTransaction,++    -- * Errors+    ORMError (..),+    DatabaseErrorInfo (..),+    DriverErrorKind (..),++    -- * Where+    Where,+    eq,+    neq,+    gt,+    gte,+    lt,+    lte,+    in_,+    contains,+    isNull,+    and_,+    or_,+    not_,++    -- * Order+    OrderBy,+    asc,+    desc,++    -- * Select / values+    OmitSelect (..),+    Picked (..),+    NullableValue (..),++    -- * Includes+    Load (..),+    load,+    loadWith,+    skip,++    -- * Raw SQL+    queryRaw,+    executeRaw,+    param,+    catchDb,++    -- * Migrations+    applyMigrations,+    MigrateError (..),+  )+where++import Poppy.Internal.Column ()+import Poppy.Internal.Core (NullableValue (..))+import Poppy.Internal.Db+  ( Db,+    DbPool,+    PoolConfig (..),+    SqlLogger,+    closePool,+    connect,+    connectWith,+    defaultPool,+    runDb,+    transaction,+    transactionEither,+    withTransaction,+  )+import Poppy.Internal.Errors (DatabaseErrorInfo (..), DriverErrorKind (..), ORMError (..))+import Poppy.Internal.Include (Load (..), load, loadWith, skip)+import Poppy.Internal.Migrate (MigrateError (..), applyMigrations)+import Poppy.Internal.Query (OrderBy, asc, desc)+import Poppy.Internal.Select (OmitSelect (..), Picked (..))+import Poppy.Internal.Sql (catchDb, executeRaw, param, queryRaw)+import Poppy.Internal.Where+  ( Where,+    and_,+    contains,+    eq,+    gt,+    gte,+    in_,+    isNull,+    lt,+    lte,+    neq,+    not_,+    or_,+  )
+ src/Poppy/Internal/Column.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++-- | 'Column' instances for Schema scalars (including @numeric@ / 'Data.Scientific.Scientific' and @jsonb@ / 'Data.Aeson.Value').+module Poppy.Internal.Column+  ( Column (..),+  )+where++import Data.Aeson (Value)+import Data.Int (Int32, Int64)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Database.PostgreSQL.Simple.FromField ()+import Database.PostgreSQL.Simple.ToField ()+import Poppy.Internal.Core (Column (..))++instance Column UUID where+  columnType = "uuid"++instance Column Text where+  columnType = "text"++instance Column Int where+  columnType = "integer"++instance Column Int32 where+  columnType = "integer"++instance Column Int64 where+  columnType = "bigint"++instance Column Scientific where+  columnType = "numeric"++instance Column Value where+  columnType = "jsonb"++instance Column UTCTime where+  columnType = "timestamp with time zone"++instance Column Bool where+  columnType = "boolean"
+ src/Poppy/Internal/Core.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}++module Poppy.Internal.Core+  ( Entity (..),+    Column (..),+    SqlType (..),+    Field (..),+    NullableValue (..),+    PrimaryKeyType,+  )+where++import Data.Text (Text)+import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.ToField (ToField)++class SqlType a where+  toSqlType :: Text++class (FromField a, ToField a) => Column a where+  columnType :: Text++data Field table a = Field+  { fieldName :: Text,+    fieldColumn :: Text+  }++class Entity table where+  tableName :: Text+  primaryKey :: Field table (PrimaryKeyType table)+  tableColumns :: [Text]+  uniqueKeys :: [[Text]]+  uniqueKeys = [[fieldColumn (primaryKey @table)]]++type family PrimaryKeyType table++-- | Three-way column input for nullable fields on create and update.+-- 'Omit' leaves the column out; 'Value' sets it; 'Null' sets SQL NULL.+data NullableValue a+  = Omit+  | Value a+  | Null+  deriving (Show, Eq)
+ src/Poppy/Internal/Db.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS_HADDOCK hide #-}+-- | Connection pool, 'Db' monad, and SQL logging.+module Poppy.Internal.Db+  ( Db (..),+    DbPool (..),+    DbEnv (..),+    PoolConfig (..),+    SqlLogger,+    defaultPool,+    connect,+    connectWith,+    closePool,+    runDb,+    withTransaction,+    transaction,+    transactionEither,+    withConn,+    dbIO,+    logSql,+    liftIO,+  )+where++import Control.Exception (handle, throwIO)+import Control.Monad.IO.Class (MonadIO (..), liftIO)+import qualified Data.ByteString.Char8 as B8+import Data.Pool (Pool, defaultPoolConfig, destroyAllResources, newPool, setNumStripes, withResource)+import Data.Text (Text)+import Database.PostgreSQL.Simple (Connection)+import qualified Database.PostgreSQL.Simple as PG+import Poppy.Internal.Errors (ORMError)++-- | Assembled SQL only; bound parameters are not logged.+type SqlLogger = Text -> IO ()++-- | Connection pool and SQL logger. Bound parameters are never logged.+data PoolConfig = PoolConfig+  { poolStripes :: Int,+    poolMaxPerStripe :: Int,+    poolIdleSeconds :: Double,+    poolSqlLog :: SqlLogger+  }++-- | 4 stripes × 5 connections, 10s idle, no SQL log.+defaultPool :: PoolConfig+defaultPool =+  PoolConfig+    { poolStripes = 4,+      poolMaxPerStripe = 5,+      poolIdleSeconds = 10,+      poolSqlLog = \_ -> pure ()+    }++-- | Pool plus SQL logger.+data DbPool = DbPool+  { unDbPool :: Pool Connection,+    dbSqlLog :: SqlLogger+  }++data DbEnv = DbEnv+  { dbConnection :: Connection,+    dbLogSql :: SqlLogger+  }++-- | Postgres work on a pooled connection.+newtype Db a = Db {unDb :: DbEnv -> IO a}++instance Functor Db where+  fmap f (Db g) = Db (fmap f . g)++instance Applicative Db where+  pure x = Db (const (pure x))+  Db f <*> Db x = Db $ \env -> f env <*> x env++instance Monad Db where+  Db m >>= f = Db $ \env -> do+    a <- m env+    unDb (f a) env++instance MonadIO Db where+  liftIO io = Db (const io)++dbIO :: (Connection -> IO a) -> Db a+dbIO action = Db $ \env -> action (dbConnection env)++logSql :: Text -> Db ()+logSql sql = Db $ \env -> dbLogSql env sql++-- | Connect with 'defaultPool'.+connect :: String -> IO DbPool+connect = connectWith defaultPool++-- | Connect with an explicit 'PoolConfig'.+connectWith :: PoolConfig -> String -> IO DbPool+connectWith config databaseUrl = do+  let totalMaxConnections = poolStripes config * poolMaxPerStripe config+      poolConfig =+        setNumStripes (Just (poolStripes config)) $+          defaultPoolConfig+            (PG.connectPostgreSQL $ B8.pack databaseUrl)+            PG.close+            (poolIdleSeconds config)+            totalMaxConnections+  pool <- newPool poolConfig+  pure DbPool {unDbPool = pool, dbSqlLog = poolSqlLog config}++-- | Destroy every connection in the pool.+closePool :: DbPool -> IO ()+closePool (DbPool pool _) = destroyAllResources pool++-- | Run a 'Db' action on one pooled connection.+runDb :: DbPool -> Db a -> IO a+runDb pool (Db action) =+  withResource (unDbPool pool) $ \conn ->+    action (DbEnv {dbConnection = conn, dbLogSql = dbSqlLog pool})++withConn :: DbPool -> (Connection -> IO a) -> IO a+withConn (DbPool pool _) = withResource pool++withTransaction :: DbPool -> Db a -> IO a+withTransaction pool (Db action) =+  withResource (unDbPool pool) $ \conn ->+    let env = DbEnv {dbConnection = conn, dbLogSql = dbSqlLog pool}+     in PG.withTransaction conn (action env)++-- | Wrap an in-flight 'Db' action in @BEGIN@/@COMMIT@ (vs 'withTransaction', which takes a pool).+transaction :: Db a -> Db a+transaction (Db action) = Db $ \env ->+  PG.withTransaction (dbConnection env) (action env)++-- | Like 'transaction', but 'Left' also rolls back. @postgresql-simple@ only+-- undoes the transaction when the action throws; 'ORMError' is rethrown inside+-- the transaction and caught afterwards so callers still see 'Either'.+transactionEither :: Db (Either ORMError a) -> Db (Either ORMError a)+transactionEither (Db action) = Db $ \env ->+  handle (pure . Left) $+    PG.withTransaction (dbConnection env) $ do+      result <- action env+      case result of+        Left err -> throwIO err+        Right val -> pure (Right val)
+ src/Poppy/Internal/Delete.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_HADDOCK hide #-}++module Poppy.Internal.Delete+  ( DeleteBuilder,+    deleteWhere,+    deleteMany,+    deleteReturning,+    whereDelete,+    emptyDelete,+  )+where++import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Database.PostgreSQL.Simple (Connection)+import qualified Database.PostgreSQL.Simple as PGSimple+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow)+import Database.PostgreSQL.Simple.ToField (Action)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Core (Entity (..))+import Poppy.Internal.Db (Db, dbIO)+import Poppy.Internal.Errors (ORMError (..))+import Poppy.Internal.Query (buildWhereClause)+import Poppy.Internal.Sql (catchSql, quoteIdent)+import Poppy.Internal.Where (Where, compileWhere)++data DeleteBuilder table = DeleteBuilder+  { dbTable :: Text,+    dbWhere :: [Text],+    dbWhereParams :: [Action]+  }++emptyDelete :: forall table. (Entity table) => DeleteBuilder table+emptyDelete =+  DeleteBuilder+    { dbTable = tableName @table,+      dbWhere = [],+      dbWhereParams = []+    }++whereDelete :: Text -> [Action] -> DeleteBuilder table -> DeleteBuilder table+whereDelete condition params builder =+  builder+    { dbWhere = dbWhere builder ++ [condition],+      dbWhereParams = dbWhereParams builder ++ params+    }++deleteWhere ::+  forall table.+  (Entity table) =>+  DeleteBuilder table ->+  Db (Either ORMError Int)+deleteWhere builder+  | null (dbWhere builder) =+      pure (Left (EmptyWhere "DELETE requires a WHERE clause"))+  | otherwise = dbIO $ \conn -> catchSql (runDeleteWhere conn builder)++deleteMany ::+  forall table.+  (Entity table) =>+  Where table ->+  Db (Either ORMError Int)+deleteMany clause =+  let (sql, params) = compileWhere clause+      builder = whereDelete sql params (emptyDelete @table)+   in deleteWhere builder++deleteReturning ::+  forall table result.+  (Entity table, FromRow result) =>+  DeleteBuilder table ->+  Db (Either ORMError [result])+deleteReturning builder+  | null (dbWhere builder) =+      pure (Left (EmptyWhere "DELETE requires a WHERE clause"))+  | otherwise = dbIO $ \conn -> catchSql (runDeleteReturning conn builder)++runDeleteWhere ::+  Connection ->+  DeleteBuilder table ->+  IO Int+runDeleteWhere conn builder = do+  let queryText =+        "DELETE FROM "+          <> quoteIdent (dbTable builder)+          <> buildWhereClause (dbWhere builder)+      query = Query (TE.encodeUtf8 queryText)+  fromIntegral <$> PGSimple.execute conn query (dbWhereParams builder)++runDeleteReturning ::+  forall table result.+  (FromRow result) =>+  Connection ->+  DeleteBuilder table ->+  IO [result]+runDeleteReturning conn builder = do+  let queryText =+        "DELETE FROM "+          <> quoteIdent (dbTable builder)+          <> buildWhereClause (dbWhere builder)+          <> " RETURNING *"+      query = Query (TE.encodeUtf8 queryText)+  PGSimple.queryWith fromRow conn query (dbWhereParams builder)
+ src/Poppy/Internal/Errors.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_HADDOCK hide #-}+-- | Errors returned as @Either ORMError@ from Client operations.+module Poppy.Internal.Errors+  ( ORMError (..),+    DatabaseErrorInfo (..),+    DriverErrorKind (..),+    requireFound,+    fromUniqueRows,+    uniqueOrFail,+    parseSingleton,+  )+where++import Control.Exception (Exception)+import Data.Text (Text)++-- | SQLSTATE, message, and detail from Postgres.+data DatabaseErrorInfo = DatabaseErrorInfo+  { sqlState :: Text,+    message :: Text,+    detail :: Text+  }+  deriving (Show, Eq)++-- | @postgresql-simple@ failures that are not constraint violations.+data DriverErrorKind+  = FormatMismatch+  | ClientQuery+  | ResultDecode+  deriving (Show, Eq)++-- | Client and driver failures. Constraint violations are classified; other @SqlError@s are 'DatabaseError'.+data ORMError+  = RecordNotFound Text+  | MultipleRecordsFound Text+  | UniqueViolation Text+  | ForeignKeyViolation Text+  | NotNullViolation Text+  | -- | A write or lookup required a @WHERE@ and none was given.+    EmptyWhere Text+  | UnsupportedIncludeModifier Text+  | -- | Other Postgres @SqlError@ (includes SQLSTATE).+    DatabaseError DatabaseErrorInfo+  | DriverError DriverErrorKind Text+  deriving (Show, Eq)++instance Exception ORMError++requireFound :: Maybe a -> ORMError -> Either ORMError a+requireFound Nothing err = Left err+requireFound (Just value) _ = Right value++fromUniqueRows :: [a] -> Either ORMError (Maybe a)+fromUniqueRows rows =+  case rows of+    [] -> Right Nothing+    [row] -> Right (Just row)+    _ -> Left (MultipleRecordsFound "findUnique matched multiple rows")++uniqueOrFail :: Either ORMError (Maybe a) -> Either ORMError a+uniqueOrFail (Left err) = Left err+uniqueOrFail (Right found) =+  requireFound found (RecordNotFound "No record found matching query")++parseSingleton :: [a] -> ORMError -> ORMError -> Either ORMError a+parseSingleton rows notFoundErr multipleErr =+  case rows of+    [] -> Left notFoundErr+    [row] -> Right row+    _ -> Left multipleErr
+ src/Poppy/Internal/Generated.hs view
@@ -0,0 +1,170 @@+-- | Support for Clients emitted by @poppy-codegen@.+--+-- Generated @Schema.*@ modules import this module and nothing else from+-- @poppy@. Application code should import 'Poppy' and @Schema.Client.*@+-- instead. The surface is stable within a major version so a Client built+-- against codegen 1.x keeps working with runtime 1.x.+module Poppy.Internal.Generated+  ( -- * Postgres bindings+    FromRow (..),+    RowParser,+    field,+    FromField (..),+    ResultError (..),+    returnError,+    ToField (..),++    -- * Table metadata+    Entity (..),+    Column (..),+    SqlType (..),+    Field (..),+    NullableValue (..),+    PrimaryKeyType,++    -- * Connection+    Db,+    DbPool,+    transactionEither,++    -- * Errors+    ORMError (..),+    DatabaseErrorInfo (..),+    DriverErrorKind (..),+    requireFound,+    fromUniqueRows,+    uniqueOrFail,+    parseSingleton,++    -- * Select / pick+    OmitSelect (..),+    Picked (..),+    picked,++    -- * Insert+    InsertBuilder,+    Insertable (..),+    insert,+    insertMany,+    insertBuilder,+    insertReturning,+    executeInsert,+    tryExecuteInsert,+    emptyInsert,+    onConflictDoNothing,+    onConflictDoUpdate,+    onConflictDoUpdateSet,+    upsert,+    set,+    setNull,+    setMaybe,+    setNullable,+    setValue,++    -- * Update+    UpdateBuilder,+    Updatable (..),+    update,+    updateWhere,+    updateBuilder,+    updateReturning,+    setField,+    setFieldNull,+    setFieldMaybe,+    setFieldNullable,+    whereUpdate,+    emptyUpdate,+    updateMany,+    updateSets,+    touchUpdatedAt,++    -- * Delete+    DeleteBuilder,+    deleteWhere,+    deleteMany,+    deleteReturning,+    whereDelete,+    emptyDelete,++    -- * Low-level reads+    findMany,+    findManyWith,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstWith,+    findFirstOrFail,+    count,+    delete,++    -- * Query builders+    QueryBuilder,+    matching,+    selectColumns,+    applyQueryModifiers,+    OrderBy (..),+    OrderDirection (..),+    asc,+    desc,+    limit,+    offset,+    orderBy,+    selectAll,+    select,++    -- * Where+    Where,+    eq,+    neq,+    gt,+    gte,+    lt,+    lte,+    in_,+    contains,+    isNull,+    and_,+    or_,+    not_,+    compileWhere,++    -- * Includes+    Skip (..),+    Load (..),+    load,+    loadWith,+    skip,+    skipped,+    Skipped,+    ModelTable,+    IncludeFor,+    ValidEdge,+    requireRelated,+    GroupIndex,+    ByPk,+    findByIn,+    emptyGroups,+    indexHasMany,+    indexHasManyMaybe,+    lookupGroups,+    emptyByPk,+    indexByPk,+    lookupByPk,+    prepareIncludeRootQuery,+  )+where++import Poppy.Internal.Column ()+import Poppy.Internal.Core+import Poppy.Internal.Db (Db, DbPool, transactionEither)+import Poppy.Internal.Delete+import Poppy.Internal.Errors+import Poppy.Internal.Include+import Poppy.Internal.Insert+import Poppy.Internal.Operations hiding (ORMError (..))+import Poppy.Internal.PG+import Poppy.Internal.Query+import Poppy.Internal.Select+import Poppy.Internal.SelectIn+import Poppy.Internal.Update+import Poppy.Internal.Where
+ src/Poppy/Internal/Group.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_HADDOCK hide #-}+module Poppy.Internal.Group+  ( groupByKey,+  )+where++import Data.List (foldl', sortOn)+import qualified Data.Map.Strict as Map++-- | Group rows by key, preserving first-seen key order and row order within+-- each group. Unlike a 'Map'-ordered group, this matches SELECT order so+-- nested includes stay stable when the join is ordered.+groupByKey :: (Ord k) => (a -> k) -> [a] -> [[a]]+groupByKey keyFn rows =+  map snd . sortOn fst . Map.elems $ foldl' add Map.empty rows+  where+    add acc row =+      Map.alter (upsert (Map.size acc) row) (keyFn row) acc+    upsert idx row Nothing = Just (idx, [row])+    upsert _ row (Just (idx, xs)) = Just (idx, xs ++ [row])
+ src/Poppy/Internal/Include.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Include edges for generated @Schema.Include.*@ modules.+--+-- 'skip' omits a relation. 'load' fetches its rows, and 'loadWith' nests+-- another include. Record-update 'where_', 'orderBy_', and 'take_' on+-- 'load' or 'loadWith' to filter that edge. 'take_' is per parent.+-- Import the result constructor+-- (@BookWith (..)@), or a skipped field is reported as a missing @HasField@+-- instance.+module Poppy.Internal.Include+  ( Skip (..),+    Load (..),+    load,+    loadWith,+    skip,+    skipped,+    Skipped,+    ModelTable,+    IncludeFor,+    ValidEdge,+    requireRelated,+  )+where++import Data.Kind (Constraint, Type)+import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)+import Poppy.Internal.Query (OrderBy)+import Poppy.Internal.Where (Where)++data Skip = Skip+  deriving (Show, Eq)++-- | One loaded relation.+--+-- 'include_' is the nested include, or @()@ when this edge stops here.+-- 'where_' and 'orderBy_' use the child table. 'take_' keeps that many+-- child rows for each parent; 'Nothing' keeps every match. Empty+-- 'orderBy_' sorts by the child primary key.+data Load table include = Load+  { include_ :: include,+    where_ :: Maybe (Where table),+    orderBy_ :: [OrderBy table],+    take_ :: Maybe Int+  }+  deriving (Show, Eq)++-- | Load every related row, with no nested include.+load :: Load table ()+load =+  Load+    { include_ = (),+      where_ = Nothing,+      orderBy_ = [],+      take_ = Nothing+    }++-- | Load related rows and nest @include_@. Filters match 'load'.+loadWith :: include -> Load table include+loadWith include_ =+  Load+    { include_ = include_,+      where_ = Nothing,+      orderBy_ = [],+      take_ = Nothing+    }++skip :: Skip+skip = Skip++-- | Placeholder stored in a skipped field. Forcing it is a type error+-- ('Skipped'), so this value is only for constructing the result.+skipped :: a+skipped = error "Poppy: relation was not included"++type Skipped (name :: Symbol) (loaded :: Type) =+  TypeError+    ( Text "'"+        :<>: Text name+        :<>: Text "' was skipped: NotIncluded vs "+        :<>: ShowType loaded+    )++-- | Generated: @type instance ModelTable \"Book\" = BookTable@.+-- Ties an include edge to the child table so 'where_' cannot target+-- a different model.+type family ModelTable (model :: Symbol) :: Type++class IncludeFor (model :: Symbol) (include :: Type)++type family ValidEdge (model :: Symbol) (edge :: Type) :: Constraint where+  ValidEdge _ Skip = ()+  ValidEdge model (Load table ()) = table ~ ModelTable model+  ValidEdge model (Load table include) =+    (table ~ ModelTable model, IncludeFor model include)+  ValidEdge model other =+    TypeError+      ( Text "A "+          :<>: Text model+          :<>: Text " relation is skip or load, got "+          :<>: ShowType other+      )++-- | A required belongs-to whose parent row is missing.+requireRelated :: String -> Maybe a -> a+requireRelated name Nothing =+  error ("Poppy: required relation '" ++ name ++ "' row was missing")+requireRelated _ (Just row) = row
+ src/Poppy/Internal/Insert.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}++module Poppy.Internal.Insert+  ( InsertBuilder,+    Insertable (..),+    insert,+    insertMany,+    insertBuilder,+    insertReturning,+    executeInsert,+    tryExecuteInsert,+    emptyInsert,+    onConflictDoNothing,+    onConflictDoUpdate,+    onConflictDoUpdateSet,+    upsert,+    set,+    setNull,+    setMaybe,+    setNullable,+    setValue,+  )+where++import Control.Monad.IO.Class (liftIO)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import Data.Time (getCurrentTime)+import Database.PostgreSQL.Simple (Connection)+import qualified Database.PostgreSQL.Simple as PGSimple+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow)+import Database.PostgreSQL.Simple.ToField (Action, ToField, toField)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Core (Entity (..), Field (..), NullableValue (..))+import Poppy.Internal.Db (Db, dbIO, transactionEither)+import Poppy.Internal.Errors (ORMError (..), parseSingleton)+import Poppy.Internal.Sql (catchSql, quoteIdent)+import qualified Poppy.Internal.Update as Update++class (Entity table) => Insertable table where+  type CreateInput table+  toInsertBuilder :: CreateInput table -> InsertBuilder table++data InsertBuilder table = InsertBuilder+  { ibTable :: Text,+    ibColumns :: [Text],+    ibValues :: [Action],+    ibConflict :: OnConflict+  }++data OnConflict+  = NoConflict+  | DoNothing [Text]+  | DoUpdate [Text] [Text]+  | DoUpdateSet [Text] [(Text, Action)]++insert ::+  forall table result.+  (Insertable table, FromRow result) =>+  CreateInput table ->+  Db (Either ORMError result)+insert input = insertBuilder (toInsertBuilder @table input)++-- | Sequential inserts in one transaction (not a multi-row @INSERT@). Empty list succeeds with @0@.+insertMany ::+  forall table.+  (Insertable table) =>+  [CreateInput table] ->+  Db (Either ORMError Int)+insertMany [] = pure (Right 0)+insertMany inputs = transactionEither (go 0 inputs)+  where+    go n [] = pure (Right n)+    go n (input : rest) = do+      result <- tryExecuteInsert (toInsertBuilder @table input)+      case result of+        Left err -> pure (Left err)+        Right () -> go (n + 1) rest++-- | @INSERT … ON CONFLICT (conflictCols) DO UPDATE@ using the update payload, not @EXCLUDED@.+upsert ::+  forall table result.+  (Insertable table, Update.Updatable table, FromRow result) =>+  [Text] ->+  CreateInput table ->+  Update.UpdateInput table ->+  Db (Either ORMError result)+upsert conflictCols createInput updateInput = do+  now <- liftIO getCurrentTime+  let insertB = toInsertBuilder @table createInput+      updateB = Update.touchUpdatedAt @table now (Update.toUpdateBuilder @table updateInput)+      sets = Update.updateSets updateB+      builder =+        if null sets+          then onConflictDoUpdate conflictCols conflictCols insertB+          else onConflictDoUpdateSet conflictCols sets insertB+  insertBuilder builder++insertBuilder ::+  forall table result.+  (FromRow result) =>+  InsertBuilder table ->+  Db (Either ORMError result)+insertBuilder builder = dbIO $ \conn -> do+  result <- catchSql (runInsertReturning conn builder)+  pure $+    case result of+      Left err -> Left err+      Right rows ->+        parseSingleton+          rows+          (RecordNotFound $ "INSERT into " <> ibTable builder <> " returned no rows")+          (MultipleRecordsFound "Insert returned multiple rows")++insertReturning ::+  forall table result.+  (FromRow result) =>+  InsertBuilder table ->+  Db [result]+insertReturning builder = dbIO (`runInsertReturning` builder)++executeInsert :: InsertBuilder table -> Db ()+executeInsert builder = dbIO (`runExecuteInsert` builder)++tryExecuteInsert :: InsertBuilder table -> Db (Either ORMError ())+tryExecuteInsert builder = dbIO $ \conn -> catchSql (runExecuteInsert conn builder)++emptyInsert :: forall table. (Entity table) => InsertBuilder table+emptyInsert =+  InsertBuilder+    { ibTable = tableName @table,+      ibColumns = [],+      ibValues = [],+      ibConflict = NoConflict+    }++onConflictDoNothing :: [Text] -> InsertBuilder table -> InsertBuilder table+onConflictDoNothing cols builder = builder {ibConflict = DoNothing cols}++onConflictDoUpdate :: [Text] -> [Text] -> InsertBuilder table -> InsertBuilder table+onConflictDoUpdate cols setCols builder = builder {ibConflict = DoUpdate cols setCols}++onConflictDoUpdateSet :: [Text] -> [(Text, Action)] -> InsertBuilder table -> InsertBuilder table+onConflictDoUpdateSet cols sets builder = builder {ibConflict = DoUpdateSet cols sets}++set :: forall table a. (ToField a) => Field table a -> a -> InsertBuilder table -> InsertBuilder table+set field value builder =+  builder+    { ibColumns = ibColumns builder ++ [fieldColumn field],+      ibValues = ibValues builder ++ [toField value]+    }++setValue :: forall table a. (Entity table, ToField a) => Field table a -> a -> InsertBuilder table+setValue field value = set field value (emptyInsert @table)++setNull ::+  forall table a.+  (ToField (Maybe a)) =>+  Field table a ->+  InsertBuilder table ->+  InsertBuilder table+setNull field builder =+  builder+    { ibColumns = ibColumns builder ++ [fieldColumn field],+      ibValues = ibValues builder ++ [toField (Nothing :: Maybe a)]+    }++setMaybe ::+  forall table a.+  (ToField a) =>+  Field table a ->+  Maybe a ->+  InsertBuilder table ->+  InsertBuilder table+setMaybe _ Nothing builder = builder+setMaybe field (Just value) builder = set field value builder++setNullable ::+  forall table a.+  (ToField a, ToField (Maybe a)) =>+  Field table a ->+  NullableValue a ->+  InsertBuilder table ->+  InsertBuilder table+setNullable _ Omit builder = builder+setNullable field (Value value) builder = set field value builder+setNullable field Null builder = setNull field builder++runInsertReturning ::+  forall table result.+  (FromRow result) =>+  Connection ->+  InsertBuilder table ->+  IO [result]+runInsertReturning conn builder =+  let (queryText, allValues) = insertQueryParts builder " RETURNING *"+      query = Query (TE.encodeUtf8 queryText)+   in PGSimple.queryWith fromRow conn query allValues++runExecuteInsert ::+  Connection ->+  InsertBuilder table ->+  IO ()+runExecuteInsert conn builder = do+  let (queryText, allValues) = insertQueryParts builder ""+      query = Query (TE.encodeUtf8 queryText)+  _ <- PGSimple.execute conn query allValues+  pure ()++insertQueryParts :: InsertBuilder table -> Text -> (Text, [Action])+insertQueryParts builder suffix =+  let allColumns = ibColumns builder+      allValues = ibValues builder+      (conflictSql, conflictParams) = conflictParts (ibConflict builder)+      placeholders = Text.intercalate ", " $ replicate (length allValues) "?"+      columnsText = Text.intercalate ", " (map quoteIdent allColumns)+      queryText =+        "INSERT INTO "+          <> quoteIdent (ibTable builder)+          <> " ("+          <> columnsText+          <> ") VALUES ("+          <> placeholders+          <> ")"+          <> conflictSql+          <> suffix+   in (queryText, allValues ++ conflictParams)++conflictParts :: OnConflict -> (Text, [Action])+conflictParts NoConflict = ("", [])+conflictParts (DoNothing cols) =+  (" ON CONFLICT (" <> Text.intercalate ", " (map quoteIdent cols) <> ") DO NOTHING", [])+conflictParts (DoUpdate cols setCols) =+  ( " ON CONFLICT ("+      <> Text.intercalate ", " (map quoteIdent cols)+      <> ") DO UPDATE SET "+      <> Text.intercalate ", " [quoteIdent col <> " = EXCLUDED." <> quoteIdent col | col <- setCols],+    []+  )+conflictParts (DoUpdateSet cols sets) =+  ( " ON CONFLICT ("+      <> Text.intercalate ", " (map quoteIdent cols)+      <> ") DO UPDATE SET "+      <> Text.intercalate ", " [quoteIdent col <> " = ?" | (col, _) <- sets],+    map snd sets+  )
+ src/Poppy/Internal/Migrate.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Apply hand-written @.sql@ files and record names in @_poppy_migrations@.+module Poppy.Internal.Migrate+  ( MigrateError (..),+    applyMigrations,+  )+where++import Control.Exception (IOException, displayException, try)+import Control.Monad (filterM, void)+import qualified Data.ByteString as B8+import Data.List (isPrefixOf, sort)+import Data.Text (Text)+import qualified Data.Text as T+import Database.PostgreSQL.Simple (Connection, Only (..))+import qualified Database.PostgreSQL.Simple as PG+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Db (DbPool, withConn)+import Poppy.Internal.Errors (ORMError)+import Poppy.Internal.Sql (catchSql)+import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)+import System.FilePath (takeExtension, (</>))++-- | Missing directory / unreadable file, or a SQL file that Postgres rejected.+data MigrateError+  = -- | Directory missing or a migration file could not be read.+    MigrateDirectoryError Text+  | -- | Postgres rejected that file; the name is not recorded.+    MigrateFailed Text ORMError+  deriving (Show, Eq)++-- | Run pending @*.sql@ files in @dir@ (sorted, not hidden) against the pool.+-- Creates @_poppy_migrations@ if needed. Returns names applied on this call.+-- A failed file is not recorded; fix it and re-run. Poppy does not generate SQL.+applyMigrations :: DbPool -> FilePath -> IO (Either MigrateError [Text])+applyMigrations pool dir = do+  listed <- listMigrationFiles dir+  case listed of+    Left err -> pure (Left err)+    Right files -> withConn pool $ \conn -> do+      ensureHistoryTable conn+      applied <- fetchApplied conn+      let pending = filter (\(name, _) -> name `notElem` applied) files+      applyPending conn pending++listMigrationFiles :: FilePath -> IO (Either MigrateError [(Text, FilePath)])+listMigrationFiles dir = do+  exists <- doesDirectoryExist dir+  if not exists+    then pure (Left (MigrateDirectoryError ("not a directory: " <> T.pack dir)))+    else do+      names <- listDirectory dir+      let sqlNames = sort (filter isMigrationName names)+      fileNames <- filterM (\name -> doesFileExist (dir </> name)) sqlNames+      pure (Right [(T.pack name, dir </> name) | name <- fileNames])++isMigrationName :: FilePath -> Bool+isMigrationName name =+  takeExtension name == ".sql" && not ("." `isPrefixOf` name)++ensureHistoryTable :: Connection -> IO ()+ensureHistoryTable conn =+  void (PG.execute_ conn historyTableSql)++historyTableSql :: Query+historyTableSql =+  "CREATE TABLE IF NOT EXISTS _poppy_migrations (\+  \ name TEXT PRIMARY KEY,\+  \ applied_at TIMESTAMPTZ NOT NULL DEFAULT CURRENT_TIMESTAMP\+  \)"++fetchApplied :: Connection -> IO [Text]+fetchApplied conn = do+  rows <- PG.query_ conn "SELECT name FROM _poppy_migrations"+  pure [name | Only name <- rows]++applyPending ::+  Connection ->+  [(Text, FilePath)] ->+  IO (Either MigrateError [Text])+applyPending conn = go []+  where+    go acc [] = pure (Right (reverse acc))+    go acc ((name, path) : rest) = do+      result <- applyOne conn name path+      case result of+        Left err -> pure (Left err)+        Right () -> go (name : acc) rest++applyOne :: Connection -> Text -> FilePath -> IO (Either MigrateError ())+applyOne conn name path = do+  sqlResult <- try @IOException (B8.readFile path)+  case sqlResult of+    Left ex ->+      pure (Left (MigrateDirectoryError (T.pack (displayException ex))))+    Right sql -> do+      result <-+        catchSql $+          PG.withTransaction conn $ do+            _ <- PG.execute_ conn (Query sql)+            _ <- PG.execute conn insertHistorySql (Only name)+            pure ()+      case result of+        Left err -> pure (Left (MigrateFailed name err))+        Right () -> pure (Right ())++insertHistorySql :: Query+insertHistorySql = "INSERT INTO _poppy_migrations (name) VALUES (?)"
+ src/Poppy/Internal/Operations.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Low-level reads used by generated Clients. Application code calls @Schema.Client.*@.+module Poppy.Internal.Operations+  ( findMany,+    findManyWith,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstWith,+    findFirstOrFail,+    count,+    delete,+    ORMError (..),+  )+where++import qualified Data.Text as Text+import Database.PostgreSQL.Simple.FromRow (FromRow, RowParser)+import Database.PostgreSQL.Simple.ToField (ToField)+import Poppy.Internal.Core (Entity (..), PrimaryKeyType)+import Poppy.Internal.Db (Db (..))+import qualified Poppy.Internal.Delete as Delete+import Poppy.Internal.Errors (ORMError (..), requireFound)+import Poppy.Internal.Query+  ( QueryBuilder,+    limit,+    matching,+    runCountQuery,+    runQuery,+    runQueryOne,+    runQueryWith,+    selectAll,+  )+import Poppy.Internal.Where (compileWhere, eq)++findMany ::+  forall table result.+  (Entity table, FromRow result) =>+  (QueryBuilder table -> QueryBuilder table) ->+  Db [result]+findMany modifier = runQuery (modifier (selectAll @table))++findManyWith ::+  forall table result.+  (Entity table) =>+  RowParser result ->+  (QueryBuilder table -> QueryBuilder table) ->+  Db [result]+findManyWith parser modifier = runQueryWith parser (modifier (selectAll @table))++findUnique ::+  forall table result.+  (Entity table, FromRow result, ToField (PrimaryKeyType table)) =>+  PrimaryKeyType table ->+  Db (Maybe result)+findUnique pkValue =+  runQueryOne $+    matching (eq (primaryKey @table) pkValue) (selectAll @table)++findUniqueOrFail ::+  forall table result.+  (Entity table, FromRow result, ToField (PrimaryKeyType table), Show (PrimaryKeyType table)) =>+  PrimaryKeyType table ->+  Db (Either ORMError result)+findUniqueOrFail pkValue = do+  result <- findUnique @table @result pkValue+  pure $+    requireFound result $+      RecordNotFound ("Record not found with primary key: " <> Text.pack (show pkValue))++findFirst ::+  forall table result.+  (Entity table, FromRow result) =>+  (QueryBuilder table -> QueryBuilder table) ->+  Db (Maybe result)+findFirst modifier = runQueryOne (modifier (selectAll @table))++findFirstWith ::+  forall table result.+  (Entity table) =>+  RowParser result ->+  (QueryBuilder table -> QueryBuilder table) ->+  Db (Maybe result)+findFirstWith parser modifier = do+  results <- runQueryWith parser (limit 1 (modifier (selectAll @table)))+  pure $ case results of+    [] -> Nothing+    (row : _) -> Just row++findFirstOrFail ::+  forall table result.+  (Entity table, FromRow result) =>+  (QueryBuilder table -> QueryBuilder table) ->+  Db (Either ORMError result)+findFirstOrFail modifier = do+  result <- findFirst @table modifier+  pure $+    requireFound result $+      RecordNotFound "No record found matching criteria"++count ::+  forall table.+  (Entity table) =>+  (QueryBuilder table -> QueryBuilder table) ->+  Db Int+count modifier = runCountQuery (modifier (selectAll @table))++delete ::+  forall table.+  (Entity table, ToField (PrimaryKeyType table)) =>+  PrimaryKeyType table ->+  Db (Either ORMError Int)+delete pkValue =+  let (sql, params) = compileWhere (eq (primaryKey @table) pkValue)+      builder = Delete.whereDelete sql params (Delete.emptyDelete @table)+   in Delete.deleteWhere builder
+ src/Poppy/Internal/PG.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_HADDOCK hide #-}+module Poppy.Internal.PG+  ( FromRow (..),+    RowParser,+    field,+    FromField (..),+    ResultError (..),+    returnError,+    ToField (..),+  )+where++import Database.PostgreSQL.Simple.FromField+  ( FromField (..),+    ResultError (..),+    returnError,+  )+import Database.PostgreSQL.Simple.FromRow (FromRow (..), RowParser, field)+import Database.PostgreSQL.Simple.ToField (ToField (..))
+ src/Poppy/Internal/Query.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Query builders used by generated Clients (@matching@, @asc@ / @desc@, @limit@).+module Poppy.Internal.Query+  ( Query,+    QueryBuilder,+    queryWhereClauses,+    queryLimit,+    queryOffset,+    queryOrderBy,+    select,+    selectAll,+    selectColumns,+    matching,+    orderBy,+    setOrderBy,+    asc,+    desc,+    limit,+    offset,+    applyQueryModifiers,+    OrderBy (..),+    OrderDirection (..),+    buildWhereClause,+    runQuery,+    runQueryWith,+    runQueryOne,+    runCountQuery,+  )+where++import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import Database.PostgreSQL.Simple (Only (..))+import qualified Database.PostgreSQL.Simple as PGSimple+import Database.PostgreSQL.Simple.FromRow (FromRow, RowParser, fromRow)+import Database.PostgreSQL.Simple.ToField (Action)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Core (Entity (..), Field (..))+import Poppy.Internal.Db (Db, dbIO, logSql)+import Poppy.Internal.Sql (quoteIdent)+import Poppy.Internal.Where (Where, compileWhere)++data QueryBuilder table = QueryBuilder+  { qbTable :: Text,+    qbColumns :: [Text],+    qbWhere :: [Where table],+    qbOrderBy :: [OrderBy table],+    qbLimit :: Maybe Int,+    qbOffset :: Maybe Int+  }++data OrderDirection = Asc | Desc+  deriving (Show, Eq)++data OrderBy table = OrderBy Text OrderDirection+  deriving (Show, Eq)++-- | @ASC@+asc :: Field table a -> OrderBy table+asc field = OrderBy (fieldColumn field) Asc++-- | @DESC@+desc :: Field table a -> OrderBy table+desc field = OrderBy (fieldColumn field) Desc++-- | All columns, no filter.+selectAll :: forall table. (Entity table) => QueryBuilder table+selectAll =+  QueryBuilder+    { qbTable = tableName @table,+      qbColumns = tableColumns @table,+      qbWhere = [],+      qbOrderBy = [],+      qbLimit = Nothing,+      qbOffset = Nothing+    }++select :: forall table. (Entity table) => QueryBuilder table+select = selectAll @table++selectColumns :: [Text] -> QueryBuilder table -> QueryBuilder table+selectColumns cols qb = qb {qbColumns = cols}++-- | Append a @WHERE@ clause (root table).+matching :: Where table -> QueryBuilder table -> QueryBuilder table+matching clause qb =+  qb {qbWhere = qbWhere qb ++ [clause]}++-- | Append an @ORDER BY@ column.+orderBy :: Field table a -> OrderDirection -> QueryBuilder table -> QueryBuilder table+orderBy field dir qb =+  qb {qbOrderBy = qbOrderBy qb ++ [OrderBy (fieldColumn field) dir]}++-- | @LIMIT@+limit :: Int -> QueryBuilder table -> QueryBuilder table+limit n qb = qb {qbLimit = Just n}++-- | @OFFSET@+offset :: Int -> QueryBuilder table -> QueryBuilder table+offset n qb = qb {qbOffset = Just n}++queryWhereClauses :: QueryBuilder table -> [(Text, [Action])]+queryWhereClauses qb =+  case qbWhere qb of+    [] -> []+    preds ->+      let compiled = map compileWhere preds+          sql = T.intercalate " AND " ["(" <> s <> ")" | (s, _) <- compiled]+          params = concatMap snd compiled+       in [(sql, params)]++queryLimit :: QueryBuilder table -> Maybe Int+queryLimit = qbLimit++queryOffset :: QueryBuilder table -> Maybe Int+queryOffset = qbOffset++queryOrderBy :: QueryBuilder table -> [OrderBy table]+queryOrderBy = qbOrderBy++applyQueryModifiers ::+  Maybe (Where table) ->+  [OrderBy table] ->+  Maybe Int ->+  Maybe Int ->+  QueryBuilder table ->+  QueryBuilder table+applyQueryModifiers mWhere orders mLimit mOffset =+  maybe id matching mWhere+    . setOrderBy orders+    . maybe id limit mLimit+    . maybe id offset mOffset++-- | Replace the @ORDER BY@ list.+setOrderBy :: [OrderBy table] -> QueryBuilder table -> QueryBuilder table+setOrderBy orders qb = qb {qbOrderBy = orders}++buildQuery :: QueryBuilder table -> (Query, [Action])+buildQuery qb =+  let baseQuery = "SELECT " <> buildSelectList (qbColumns qb) <> " FROM " <> quoteIdent (qbTable qb)+      clauses = queryWhereClauses qb+      whereClause = buildWhereClause (map fst clauses)+      orderClause = buildOrderClause (qbOrderBy qb)+      limitClause = buildLimitClause (qbLimit qb)+      offsetClause = buildOffsetClause (qbOffset qb)+      finalQuery = baseQuery <> whereClause <> orderClause <> limitClause <> offsetClause+   in (Query (TE.encodeUtf8 finalQuery), concatMap snd clauses)++buildSelectList :: [Text] -> Text+buildSelectList cols = T.intercalate ", " (map quoteIdent cols)++buildCountQuery :: QueryBuilder table -> (Query, [Action])+buildCountQuery qb =+  let clauses = queryWhereClauses qb+      finalQuery = "SELECT COUNT(*) FROM " <> quoteIdent (qbTable qb) <> buildWhereClause (map fst clauses)+   in (Query (TE.encodeUtf8 finalQuery), concatMap snd clauses)++buildWhereClause :: [Text] -> Text+buildWhereClause [] = ""+buildWhereClause conditions = " WHERE " <> T.intercalate " AND " conditions++buildOrderClause :: [OrderBy table] -> Text+buildOrderClause [] = ""+buildOrderClause terms =+  " ORDER BY " <> T.intercalate ", " (map termSql terms)+  where+    termSql (OrderBy col dir) =+      quoteIdent col <> case dir of+        Asc -> " ASC"+        Desc -> " DESC"++buildLimitClause :: Maybe Int -> Text+buildLimitClause Nothing = ""+buildLimitClause (Just n) = " LIMIT " <> T.pack (show n)++buildOffsetClause :: Maybe Int -> Text+buildOffsetClause Nothing = ""+buildOffsetClause (Just n) = " OFFSET " <> T.pack (show n)++runQuery :: (FromRow result) => QueryBuilder table -> Db [result]+runQuery = runQueryWith fromRow++runQueryWith :: RowParser result -> QueryBuilder table -> Db [result]+runQueryWith parser qb = do+  let (query, params) = buildQuery qb+  logSql (queryText query)+  dbIO $ \conn -> PGSimple.queryWith parser conn query params++runQueryOne :: (FromRow result) => QueryBuilder table -> Db (Maybe result)+runQueryOne qb = do+  results <- runQuery (limit 1 qb)+  pure $ case results of+    [] -> Nothing+    (x : _) -> Just x++runCountQuery :: QueryBuilder table -> Db Int+runCountQuery qb = do+  let (query, params) = buildCountQuery qb+  logSql (queryText query)+  dbIO $ \conn -> do+    [Only count] <- PGSimple.query conn query params+    pure (fromIntegral (count :: Int64))++queryText :: Query -> Text+queryText (Query bytes) = TE.decodeUtf8With lenientDecode bytes
+ src/Poppy/Internal/Select.hs view
@@ -0,0 +1,22 @@+{-# OPTIONS_HADDOCK hide #-}+-- | Column picking for generated @*Select@ records. Default is 'OmitSelect' (full row).+module Poppy.Internal.Select+  ( OmitSelect (..),+    Picked (..),+    picked,+  )+where++-- | @select_@ default: every column, result is the full row type.+data OmitSelect = OmitSelect+  deriving (Show, Eq)++-- | One column in a partial select.+data Picked a+  = Picked a+  | Skipped+  deriving (Show, Eq)++picked :: Bool -> a -> Picked a+picked True value = Picked value+picked False _ = Skipped
+ src/Poppy/Internal/SelectIn.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}++module Poppy.Internal.SelectIn+  ( GroupIndex,+    ByPk,+    findByIn,+    emptyGroups,+    indexHasMany,+    indexHasManyMaybe,+    lookupGroups,+    emptyByPk,+    indexByPk,+    lookupByPk,+    prepareIncludeRootQuery,+  )+where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Database.PostgreSQL.Simple as PGSimple+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow)+import Database.PostgreSQL.Simple.ToField (Action, ToField, toField)+import Database.PostgreSQL.Simple.Types (In (..), Query (..))+import Poppy.Internal.Core (Entity (..), Field (..))+import Poppy.Internal.Db (Db, dbIO, logSql)+import Poppy.Internal.Group (groupByKey)+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Query+  ( OrderBy (..),+    OrderDirection (..),+    QueryBuilder,+    matching,+    orderBy,+    queryOrderBy,+    setOrderBy,+  )+import Poppy.Internal.Sql (quoteIdent)+import Poppy.Internal.Where (Where, compileWhere, in_)++newtype GroupIndex k a = GroupIndex (Map k [a])++newtype ByPk k a = ByPk (Map k a)++findByIn ::+  forall table result key.+  (Entity table, FromRow result, ToField key) =>+  Field table key ->+  [key] ->+  Maybe (Where table) ->+  [OrderBy table] ->+  Maybe Int ->+  Db [result]+findByIn field keys mWhere orders mTake+  | null keys = pure []+  | Just n <- mTake, n <= 0 = pure []+  | Just n <- mTake = findTaken @table @result field keys mWhere orders n+  | otherwise =+      Ops.findMany @table @result $+        setOrderBy (childOrder @table orders)+          . maybe id matching mWhere+          . matching (in_ field keys)++findTaken ::+  forall table result key.+  (Entity table, FromRow result, ToField key) =>+  Field table key ->+  [key] ->+  Maybe (Where table) ->+  [OrderBy table] ->+  Int ->+  Db [result]+findTaken field keys mWhere orders n = do+  let (sql, params) = takenSql @table field keys mWhere orders n+  logSql sql+  dbIO $ \conn -> PGSimple.queryWith fromRow conn (Query (TE.encodeUtf8 sql)) params++takenSql ::+  forall table key.+  (Entity table, ToField key) =>+  Field table key ->+  [key] ->+  Maybe (Where table) ->+  [OrderBy table] ->+  Int ->+  (Text, [Action])+takenSql field keys mWhere orders n =+  let cols = T.intercalate ", " (map quoteIdent (tableColumns @table))+      part = quoteIdent (fieldColumn field)+      rn = quoteIdent "poppy_rn"+      (extraSql, extraParams) = case mWhere of+        Nothing -> ("", [])+        Just pred_ ->+          let (clause, clauseParams) = compileWhere pred_+           in (" AND (" <> clause <> ")", clauseParams)+      sql =+        "SELECT "+          <> cols+          <> " FROM (SELECT "+          <> cols+          <> ", ROW_NUMBER() OVER (PARTITION BY "+          <> part+          <> " ORDER BY "+          <> orderSql (childOrder @table orders)+          <> ") AS "+          <> rn+          <> " FROM "+          <> quoteIdent (tableName @table)+          <> " WHERE "+          <> part+          <> " IN ?"+          <> extraSql+          <> ") AS "+          <> quoteIdent "poppy_window"+          <> " WHERE "+          <> rn+          <> " <= ? ORDER BY "+          <> part+          <> " ASC, "+          <> rn+          <> " ASC"+   in (sql, toField (In keys) : extraParams ++ [toField n])++childOrder :: forall table. (Entity table) => [OrderBy table] -> [OrderBy table]+childOrder orders+  | null orders = [OrderBy pk Asc]+  | any isPk orders = orders+  | otherwise = orders ++ [OrderBy pk Asc]+  where+    pk = fieldColumn (primaryKey @table)+    isPk (OrderBy col _) = col == pk++orderSql :: [OrderBy table] -> Text+orderSql orders = T.intercalate ", " (map term orders)+  where+    term (OrderBy col dir) =+      quoteIdent col <> case dir of+        Asc -> " ASC"+        Desc -> " DESC"++emptyGroups :: GroupIndex k a+emptyGroups = GroupIndex Map.empty++indexHasMany :: (Ord k) => (a -> k) -> [a] -> GroupIndex k a+indexHasMany keyFn rows =+  GroupIndex . Map.fromList $+    [(keyFn (head group), group) | group <- groupByKey keyFn rows]++-- | Like 'indexHasMany', dropping rows whose key is 'Nothing'.+indexHasManyMaybe :: (Ord k) => (a -> Maybe k) -> [a] -> GroupIndex k a+indexHasManyMaybe keyFn rows =+  GroupIndex $+    Map.fromListWith (flip (<>)) [(key, [row]) | row <- rows, Just key <- [keyFn row]]++lookupGroups :: (Ord k) => k -> GroupIndex k a -> [a]+lookupGroups key (GroupIndex groups) =+  Map.findWithDefault [] key groups++emptyByPk :: ByPk k a+emptyByPk = ByPk Map.empty++indexByPk :: (Ord k) => (a -> k) -> [a] -> ByPk k a+indexByPk keyFn rows =+  ByPk (Map.fromList [(keyFn row, row) | row <- rows])++lookupByPk :: (Ord k) => k -> ByPk k a -> Maybe a+lookupByPk key (ByPk byPk) =+  Map.lookup key byPk++prepareIncludeRootQuery ::+  forall table.+  (Entity table) =>+  (QueryBuilder table -> QueryBuilder table) ->+  QueryBuilder table ->+  QueryBuilder table+prepareIncludeRootQuery modifier =+  defaultPkOrder @table . modifier++defaultPkOrder ::+  forall table.+  (Entity table) =>+  QueryBuilder table ->+  QueryBuilder table+defaultPkOrder qb =+  case queryOrderBy qb of+    [] -> orderBy (primaryKey @table) Asc qb+    _ -> qb
+ src/Poppy/Internal/Sql.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_HADDOCK hide #-}+-- | Raw SQL in 'Poppy.Internal.Db.Db': @queryRaw@ / @executeRaw@ with bound 'param's.+module Poppy.Internal.Sql+  ( Param (..),+    param,+    queryRaw,+    executeRaw,+    catchDb,+    catchSql,+    fromSqlError,+    quoteIdent,+    quoteQualified,+  )+where++import Control.Exception (Handler (..), catches)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Database.PostgreSQL.Simple+  ( FormatError (..),+    QueryError (..),+    SqlError (..),+  )+import qualified Database.PostgreSQL.Simple as PGSimple+import Database.PostgreSQL.Simple.FromField (ResultError (..))+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow)+import Database.PostgreSQL.Simple.ToField (Action, ToField, toField)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Db (Db (..), dbIO, logSql)+import Poppy.Internal.Errors (DatabaseErrorInfo (..), DriverErrorKind (..), ORMError (..))++newtype Param = Param {unParam :: Action}++-- | Bind a @ToField@ value as a @?@ placeholder.+param :: (ToField a) => a -> Param+param = Param . toField++quoteIdent :: Text -> Text+quoteIdent name = "\"" <> T.replace "\"" "\"\"" name <> "\""++quoteQualified :: Text -> Text -> Text+quoteQualified alias col = quoteIdent alias <> "." <> quoteIdent col++-- | @SELECT@ (or anything with a 'FromRow' result). Does not catch driver errors; wrap with 'catchDb'.+queryRaw :: (FromRow r) => Query -> [Param] -> Db [r]+queryRaw query params = do+  logSql (sqlText query)+  dbIO $ \conn ->+    PGSimple.queryWith fromRow conn query (map unParam params)++-- | Statement with no result rows. Returns affected row count. Does not catch driver errors.+executeRaw :: Query -> [Param] -> Db Int+executeRaw query params = do+  logSql (sqlText query)+  dbIO $ \conn ->+    fromIntegral <$> PGSimple.execute conn query (map unParam params)++sqlText :: Query -> Text+sqlText (Query bytes) = decodeUtf8With lenientDecode bytes++-- | Turn a driver exception into 'Left' 'ORMError'.+catchDb :: Db a -> Db (Either ORMError a)+catchDb (Db action) = Db $ \env -> catchSql (action env)++catchSql :: IO a -> IO (Either ORMError a)+catchSql action =+  (Right <$> action)+    `catches` [ Handler (pure . Left . fromSqlError),+                Handler (pure . Left . fromFormatError),+                Handler (pure . Left . fromQueryError),+                Handler (pure . Left . fromResultError)+              ]++fromSqlError :: SqlError -> ORMError+fromSqlError SqlError {sqlState = state, sqlErrorMsg = msg, sqlErrorDetail = detail}+  | state == "23505" = UniqueViolation (decode msg)+  | state == "23503" = ForeignKeyViolation (decode msg)+  | state == "23502" = NotNullViolation (decode msg)+  | otherwise =+      databaseError (decode state) (decode msg) (decode detail)+  where+    decode = decodeUtf8With lenientDecode++fromFormatError :: FormatError -> ORMError+fromFormatError FormatError {fmtMessage} =+  DriverError FormatMismatch (T.pack fmtMessage)++fromQueryError :: QueryError -> ORMError+fromQueryError QueryError {qeMessage} =+  DriverError ClientQuery (T.pack qeMessage)++fromResultError :: ResultError -> ORMError+fromResultError err =+  DriverError ResultDecode (T.pack (resultMessage err))+  where+    resultMessage Incompatible {errMessage} = errMessage+    resultMessage UnexpectedNull {errMessage} = errMessage+    resultMessage ConversionFailed {errMessage} = errMessage++databaseError :: Text -> Text -> Text -> ORMError+databaseError sqlState message detail =+  DatabaseError DatabaseErrorInfo {sqlState, message, detail}
+ src/Poppy/Internal/Update.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_HADDOCK hide #-}++module Poppy.Internal.Update+  ( UpdateBuilder,+    Updatable (..),+    update,+    updateWhere,+    updateBuilder,+    updateReturning,+    setField,+    setFieldNull,+    setFieldMaybe,+    setFieldNullable,+    whereUpdate,+    emptyUpdate,+    updateMany,+    updateSets,+    touchUpdatedAt,+  )+where++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TE+import Data.Time (UTCTime, getCurrentTime)+import Database.PostgreSQL.Simple (Connection)+import qualified Database.PostgreSQL.Simple as PGSimple+import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow)+import Database.PostgreSQL.Simple.ToField (Action, ToField, toField)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Core (Entity (..), Field (..), NullableValue (..), PrimaryKeyType)+import Poppy.Internal.Db (Db (..), dbIO)+import Poppy.Internal.Errors (ORMError (..), parseSingleton)+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Query (buildWhereClause, matching)+import Poppy.Internal.Sql (catchSql, quoteIdent)+import Poppy.Internal.Where (Where, compileWhere)++class (Entity table) => Updatable table where+  type UpdateInput table+  toUpdateBuilder :: UpdateInput table -> UpdateBuilder table+  updatedAtField :: Maybe (Field table UTCTime)+  default updatedAtField :: Maybe (Field table UTCTime)+  updatedAtField = Nothing++data UpdateBuilder table = UpdateBuilder+  { ubTable :: Text,+    ubSets :: [(Text, Action)],+    ubWhere :: [Text],+    ubWhereParams :: [Action]+  }++emptyUpdate :: forall table. (Entity table) => UpdateBuilder table+emptyUpdate =+  UpdateBuilder+    { ubTable = tableName @table,+      ubSets = [],+      ubWhere = [],+      ubWhereParams = []+    }++setField :: forall table a. (ToField a) => Field table a -> a -> UpdateBuilder table -> UpdateBuilder table+setField field value builder =+  builder+    { ubSets = ubSets builder ++ [(fieldColumn field, toField value)]+    }++setFieldNull ::+  forall table a.+  (ToField (Maybe a)) =>+  Field table a ->+  UpdateBuilder table ->+  UpdateBuilder table+setFieldNull field builder =+  builder+    { ubSets = ubSets builder ++ [(fieldColumn field, toField (Nothing :: Maybe a))]+    }++setFieldMaybe ::+  forall table a.+  (ToField a) =>+  Field table a ->+  Maybe a ->+  UpdateBuilder table ->+  UpdateBuilder table+setFieldMaybe _ Nothing builder = builder+setFieldMaybe field (Just value) builder = setField field value builder++setFieldNullable ::+  forall table a.+  (ToField a, ToField (Maybe a)) =>+  Field table a ->+  NullableValue a ->+  UpdateBuilder table ->+  UpdateBuilder table+setFieldNullable _ Omit builder = builder+setFieldNullable field (Value value) builder = setField field value builder+setFieldNullable field Null builder = setFieldNull field builder++whereUpdate :: Text -> [Action] -> UpdateBuilder table -> UpdateBuilder table+whereUpdate condition params builder =+  builder+    { ubWhere = ubWhere builder ++ [condition],+      ubWhereParams = ubWhereParams builder ++ params+    }++update ::+  forall table result.+  (Updatable table, FromRow result, ToField (PrimaryKeyType table), Show (PrimaryKeyType table)) =>+  PrimaryKeyType table ->+  UpdateInput table ->+  Db (Either ORMError result)+update pkValue input = do+  let builder = toUpdateBuilder @table input+  if null (ubSets builder)+    then Ops.findUniqueOrFail @table @result pkValue+    else do+      now <- liftCurrentTime+      let pkField = primaryKey @table+          builderWithTouch = touchUpdatedAt @table now builder+          builderWithWhere =+            whereUpdate+              (quoteIdent (fieldColumn pkField) <> " = ?")+              [toField pkValue]+              builderWithTouch+      updateBuilder builderWithWhere++updateWhere ::+  forall table result.+  (Updatable table, FromRow result) =>+  Where table ->+  UpdateInput table ->+  Db (Either ORMError result)+updateWhere clause input = do+  let builder = toUpdateBuilder @table input+  if null (ubSets builder)+    then do+      rows <- Ops.findMany @table @result (matching clause)+      pure $+        parseSingleton+          rows+          (RecordNotFound "No record found to update")+          (MultipleRecordsFound "Update matched multiple rows")+    else do+      now <- liftCurrentTime+      let (sql, params) = compileWhere clause+          builderWithWhere =+            whereUpdate sql params (touchUpdatedAt @table now builder)+      updateBuilder builderWithWhere++updateBuilder ::+  forall table result.+  (Entity table, FromRow result) =>+  UpdateBuilder table ->+  Db (Either ORMError result)+updateBuilder builder+  | null (ubWhere builder) =+      pure (Left (EmptyWhere "UPDATE requires a WHERE clause"))+  | otherwise = dbIO $ \conn -> do+      result <- catchSql (runUpdateReturning conn builder)+      pure $+        case result of+          Left err -> Left err+          Right rows ->+            parseSingleton+              rows+              (RecordNotFound "No record found to update")+              (MultipleRecordsFound "Update affected multiple rows")++updateReturning ::+  forall table result.+  (Entity table, FromRow result) =>+  UpdateBuilder table ->+  Db (Either ORMError [result])+updateReturning builder+  | null (ubWhere builder) =+      pure (Left (EmptyWhere "UPDATE requires a WHERE clause"))+  | otherwise = dbIO $ \conn -> catchSql (runUpdateReturning conn builder)++updateMany ::+  forall table.+  (Updatable table) =>+  Where table ->+  UpdateInput table ->+  Db (Either ORMError Int)+updateMany clause input = do+  now <- liftCurrentTime+  let (sql, params) = compileWhere clause+      builder =+        whereUpdate sql params $+          touchUpdatedAt @table now (toUpdateBuilder @table input)+  if null (ubSets builder)+    then pure (Right 0)+    else dbIO $ \conn -> catchSql (runUpdate conn builder)++updateSets :: UpdateBuilder table -> [(Text, Action)]+updateSets = ubSets++liftCurrentTime :: Db UTCTime+liftCurrentTime = Db (const getCurrentTime)++buildSetClause :: [(Text, Action)] -> Text+buildSetClause sets = " SET " <> Text.intercalate ", " (map (\(col, _) -> quoteIdent col <> " = ?") sets)++runUpdateReturning ::+  forall table result.+  (FromRow result) =>+  Connection ->+  UpdateBuilder table ->+  IO [result]+runUpdateReturning conn builder = do+  let setClause = buildSetClause (ubSets builder)+      setParams = map snd (ubSets builder)+      whereClause = buildWhereClause (ubWhere builder)+      allParams = setParams ++ ubWhereParams builder+      queryText =+        "UPDATE "+          <> quoteIdent (ubTable builder)+          <> setClause+          <> whereClause+          <> " RETURNING *"+      query = Query (TE.encodeUtf8 queryText)+  PGSimple.queryWith fromRow conn query allParams++runUpdate :: Connection -> UpdateBuilder table -> IO Int+runUpdate conn builder = do+  let setClause = buildSetClause (ubSets builder)+      setParams = map snd (ubSets builder)+      whereClause = buildWhereClause (ubWhere builder)+      allParams = setParams ++ ubWhereParams builder+      queryText =+        "UPDATE "+          <> quoteIdent (ubTable builder)+          <> setClause+          <> whereClause+      query = Query (TE.encodeUtf8 queryText)+  fromIntegral <$> PGSimple.execute conn query allParams++touchUpdatedAt ::+  forall table.+  (Updatable table) =>+  UTCTime ->+  UpdateBuilder table ->+  UpdateBuilder table+touchUpdatedAt now builder =+  case updatedAtField @table of+    Nothing -> builder+    Just field ->+      if fieldColumn field `elem` map fst (ubSets builder)+        then builder+        else setField field now builder
+ src/Poppy/Internal/Where.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}++-- | Predicates for query records and include edges.+--+-- On a generated query record, @where_@ filters the root model. On 'load'+-- or 'loadWith', @where_@ filters that included relation.+module Poppy.Internal.Where+  ( Where,+    eq,+    neq,+    gt,+    gte,+    lt,+    lte,+    in_,+    contains,+    isNull,+    and_,+    or_,+    not_,+    compileWhere,+    equalityColumns,+  )+where++import Data.Text (Text, unpack)+import Database.PostgreSQL.Simple.ToField (Action, ToField, toField)+import Database.PostgreSQL.Simple.Types (In (..))+import Poppy.Internal.Core (Field (..))+import Poppy.Internal.Sql (quoteIdent)++-- | Predicate on one table: the root of a query record, or the child of an include edge.+data Where table+  = WhereCmp Text Text Action+  | WhereIn Text Action+  | WhereNull Text+  | WhereContains Text Action+  | WhereAnd (Where table) (Where table)+  | WhereOr (Where table) (Where table)+  | WhereNot (Where table)+  | WhereFalse++instance Eq (Where table) where+  WhereCmp c1 op1 v1 == WhereCmp c2 op2 v2 =+    c1 == c2 && op1 == op2 && sameAction v1 v2+  WhereIn c1 v1 == WhereIn c2 v2 = c1 == c2 && sameAction v1 v2+  WhereNull c1 == WhereNull c2 = c1 == c2+  WhereContains c1 v1 == WhereContains c2 v2 = c1 == c2 && sameAction v1 v2+  WhereAnd a1 b1 == WhereAnd a2 b2 = a1 == a2 && b1 == b2+  WhereOr a1 b1 == WhereOr a2 b2 = a1 == a2 && b1 == b2+  WhereNot a == WhereNot b = a == b+  WhereFalse == WhereFalse = True+  _ == _ = False++instance Show (Where table) where+  show where_ = unpack (fst (compileWhere where_))++sameAction :: Action -> Action -> Bool+sameAction a b = show a == show b++infixr 3 `and_`++infixr 2 `or_`++-- | @=@+eq :: (ToField a) => Field table a -> a -> Where table+eq = cmp "="++-- | @<>@+neq :: (ToField a) => Field table a -> a -> Where table+neq = cmp "<>"++-- | @>@+gt :: (ToField a) => Field table a -> a -> Where table+gt = cmp ">"++-- | @>=@+gte :: (ToField a) => Field table a -> a -> Where table+gte = cmp ">="++-- | @<@+lt :: (ToField a) => Field table a -> a -> Where table+lt = cmp "<"++-- | @<=@+lte :: (ToField a) => Field table a -> a -> Where table+lte = cmp "<="++-- | @IN (…)@. Empty list is false.+in_ :: (ToField a) => Field table a -> [a] -> Where table+in_ _ [] = WhereFalse+in_ field values = WhereIn (fieldColumn field) (toField (In values))++-- | Case-insensitive substring match (@POSITION@ of the needle in the column).+contains :: Field table Text -> Text -> Where table+contains field value =+  WhereContains (fieldColumn field) (toField value)++-- | @IS NULL@+isNull :: Field table a -> Where table+isNull field = WhereNull (fieldColumn field)++-- | @AND@+and_ :: Where table -> Where table -> Where table+and_ = WhereAnd++-- | @OR@+or_ :: Where table -> Where table -> Where table+or_ = WhereOr++-- | @NOT@+not_ :: Where table -> Where table+not_ = WhereNot++cmp :: (ToField a) => Text -> Field table a -> a -> Where table+cmp op field value =+  WhereCmp (fieldColumn field) op (toField value)++-- | Column names of a conjunction of equalities. 'Nothing' if the predicate+-- uses anything other than 'eq' combined with 'and_'.+equalityColumns :: Where table -> Maybe [Text]+equalityColumns = \case+  WhereCmp col "=" _ -> Just [col]+  WhereAnd left right -> (++) <$> equalityColumns left <*> equalityColumns right+  _ -> Nothing++compileWhere :: Where table -> (Text, [Action])+compileWhere = \case+  WhereCmp col op val -> (quoteIdent col <> " " <> op <> " ?", [val])+  WhereIn col val -> (quoteIdent col <> " IN ?", [val])+  WhereNull col -> (quoteIdent col <> " IS NULL", [])+  WhereContains col val ->+    ("POSITION(LOWER(?) IN LOWER(" <> quoteIdent col <> ")) > 0", [val])+  WhereAnd left right -> compileBin "AND" left right+  WhereOr left right -> compileBin "OR" left right+  WhereNot inner ->+    let (sql, params) = compileWhere inner+     in ("NOT (" <> sql <> ")", params)+  WhereFalse -> ("FALSE", [])++compileBin :: Text -> Where table -> Where table -> (Text, [Action])+compileBin op left right =+  let (leftSql, leftParams) = compileWhere left+      (rightSql, rightParams) = compileWhere right+   in ("(" <> leftSql <> ") " <> op <> " (" <> rightSql <> ")", leftParams ++ rightParams)
+ test/Poppy/AuthorFixtures.hs view
@@ -0,0 +1,25 @@+module Poppy.AuthorFixtures+  ( insertAuthor,+    insertPost,+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy (runDb)+import Poppy.Internal.Db (DbPool)+import qualified Poppy.Internal.Insert as Insert+import Schema.Author (AuthorCreate (..), AuthorRow (..), AuthorTable)+import Schema.Post (PostCreate (..), PostRow (..), PostTable)+import Schema.PostStatus (PostStatus)+import Support.Assert (assertRight)++insertAuthor :: DbPool -> Text -> IO AuthorRow+insertAuthor pool name =+  runDb pool (Insert.insert @AuthorTable @AuthorRow (AuthorCreate {id = Nothing, name}))+    >>= assertRight++insertPost :: DbPool -> UUID -> Text -> PostStatus -> IO PostRow+insertPost pool authorId title status =+  runDb pool (Insert.insert @PostTable @PostRow (PostCreate {id = Nothing, authorId, title, status}))+    >>= assertRight
+ test/Poppy/BelongsToSpec.hs view
@@ -0,0 +1,42 @@+module Poppy.BelongsToSpec+  ( belongsToSpec,+  )+where++import Poppy (load, runDb, skip)+import qualified Poppy.AuthorFixtures as AuthorFixtures+import Schema.Author (AuthorRow (..))+import qualified Schema.Client.Post as Post+import Schema.Include.Post (PostInclude (..), PostWith (..))+import Schema.Post (PostRow (..))+import Schema.PostStatus (PostStatus (..))+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe)++belongsToSpec :: SpecWith TestEnv+belongsToSpec =+  describe "belongsTo includes" $ do+    it "nests the parent row on each child" $ \TestEnv {envPool = pool} -> do+      ada <- AuthorFixtures.insertAuthor pool "Ada"+      grace <- AuthorFixtures.insertAuthor pool "Grace"+      notes <- AuthorFixtures.insertPost pool ada.id "Notes" Draft+      compiler <- AuthorFixtures.insertPost pool grace.id "Compiler" Published+      results <-+        runDb+          pool+          (Post.findMany (Post.emptyQuery {Post.include_ = PostInclude {author = load}}))+      let adaPost = head [r | r <- results, r.post.id == notes.id]+          gracePost = head [r | r <- results, r.post.id == compiler.id]+      adaPost.author.name `shouldBe` "Ada"+      adaPost.author.id `shouldBe` ada.id+      gracePost.author.name `shouldBe` "Grace"+      gracePost.author.id `shouldBe` grace.id++    it "leaves a skipped parent unread" $ \TestEnv {envPool = pool} -> do+      ada <- AuthorFixtures.insertAuthor pool "Ada"+      _ <- AuthorFixtures.insertPost pool ada.id "Notes" Draft+      results <-+        runDb+          pool+          (Post.findMany (Post.emptyQuery {Post.include_ = PostInclude {author = skip}}))+      map ((.title) . (.post)) results `shouldBe` ["Notes"]
+ test/Poppy/ClientWriteSpec.hs view
@@ -0,0 +1,125 @@+module Poppy.ClientWriteSpec+  ( clientWriteSpec,+  )+where++import Data.Text (Text)+import Data.UUID.V4 (nextRandom)+import Poppy (NullableValue (Omit, Value), ORMError (..), eq, runDb)+import qualified Schema.Client.Widget as Widget+import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetUpdate (..), widgetName)+import Support.Assert (assertRight)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldMatchList, shouldSatisfy)++clientWriteSpec :: SpecWith TestEnv+clientWriteSpec =+  describe "generated Client batch writes" $ do+    it "createMany inserts rows and counts them" $ \TestEnv {envPool = pool} -> do+      n <-+        runDb pool (Widget.createMany [widgetCreate "batch-a", widgetCreate "batch-b"])+          >>= assertRight+      n `shouldBe` 2+      rows <- runDb pool (Widget.findMany Widget.emptyQuery)+      map (.name) rows `shouldMatchList` ["batch-a", "batch-b"]++    it "createMany rolls back when one insert fails" $ \TestEnv {envPool = pool} -> do+      uid <- nextRandom+      result <-+        runDb+          pool+          ( Widget.createMany+              [ (widgetCreate "keep-me") {id = Just uid},+                (widgetCreate "also-same-id") {id = Just uid}+              ]+          )+      result+        `shouldSatisfy` ( \case+                            Left (UniqueViolation _) -> True+                            _ -> False+                        )+      rows <- runDb pool (Widget.findMany Widget.emptyQuery)+      rows `shouldBe` []++    it "updateMany updates matching rows" $ \TestEnv {envPool = pool} -> do+      _ <- runDb pool (Widget.create (widgetCreate "before")) >>= assertRight+      _ <- runDb pool (Widget.create (widgetCreate "other")) >>= assertRight+      n <-+        runDb+          pool+          ( Widget.updateMany+              (eq widgetName "before")+              widgetUpdate {name = Just "after"}+          )+          >>= assertRight+      n `shouldBe` 1+      rows <- runDb pool (Widget.findMany Widget.emptyQuery)+      map (.name) rows `shouldMatchList` ["after", "other"]++    it "deleteMany deletes matching rows" $ \TestEnv {envPool = pool} -> do+      _ <- runDb pool (Widget.create (widgetCreate "keep")) >>= assertRight+      _ <- runDb pool (Widget.create (widgetCreate "drop")) >>= assertRight+      n <- runDb pool (Widget.deleteMany (eq widgetName "drop")) >>= assertRight+      n `shouldBe` 1+      rows <- runDb pool (Widget.findMany Widget.emptyQuery)+      map (.name) rows `shouldBe` ["keep"]++    it "upsert OnName updates on conflict" $ \TestEnv {envPool = pool} -> do+      inserted <-+        runDb+          pool+          (Widget.upsert Widget.OnName (widgetCreate "first") widgetUpdate)+          >>= assertRight+      inserted.name `shouldBe` "first"+      updated <-+        runDb+          pool+          ( Widget.upsert+              Widget.OnName+              (widgetCreate "first")+              widgetUpdate {name = Just "second"}+          )+          >>= assertRight+      updated.id `shouldBe` inserted.id+      updated.name `shouldBe` "second"+      rows <- runDb pool (Widget.findMany Widget.emptyQuery)+      map (.name) rows `shouldBe` ["second"]++    it "update and delete take a unique key" $ \TestEnv {envPool = pool} -> do+      created <- runDb pool (Widget.create (widgetCreate "sage")) >>= assertRight+      same <-+        runDb pool (Widget.update (Widget.ByName "sage") widgetUpdate)+          >>= assertRight+      same.id `shouldBe` created.id+      updated <-+        runDb+          pool+          ( Widget.update+              (Widget.ByName "sage")+              widgetUpdate {description = Value "fresh"}+          )+          >>= assertRight+      updated.description `shouldBe` Just "fresh"+      n <-+        runDb pool (Widget.delete (Widget.ById created.id))+          >>= assertRight+      n `shouldBe` 1++widgetCreate :: Text -> WidgetCreate+widgetCreate name =+  WidgetCreate+    { id = Nothing,+      createdAt = Nothing,+      updatedAt = Nothing,+      name,+      description = Omit+    }++widgetUpdate :: WidgetUpdate+widgetUpdate =+  WidgetUpdate+    { createdAt = Nothing,+      updatedAt = Nothing,+      name = Nothing,+      description = Omit+    }
+ test/Poppy/CommentSpec.hs view
@@ -0,0 +1,45 @@+module Poppy.CommentSpec+  ( commentSpec,+  )+where++import Poppy (NullableValue (..), load, loadWith, runDb)+import qualified Poppy.Internal.Insert as Insert+import Poppy.Internal.Where (isNull)+import qualified Schema.Client.Comment as Comment+import Schema.Comment (CommentCreate (..), CommentRow (..), CommentTable, commentParentId)+import Schema.Include.Comment (CommentInclude (..), CommentWith (..))+import Support.Assert (assertRight)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe)++commentSpec :: SpecWith TestEnv+commentSpec =+  describe "self-relation includes" $+    it "loads replies two levels deep" $ \TestEnv {envPool = pool} -> do+      root <- insert pool "root" Null+      child <- insert pool "child" (Value root.id)+      _ <- insert pool "grandchild" (Value child.id)+      [loaded] <-+        runDb+          pool+          ( Comment.findMany+              Comment.emptyQuery+                { Comment.include_ =+                    CommentInclude {replies = loadWith (CommentInclude {replies = load})},+                  Comment.where_ = Just (isNull commentParentId)+                }+          )+      [reply] <- pure loaded.replies+      reply.comment.body `shouldBe` "child"+      map (.body) reply.replies `shouldBe` ["grandchild"]+  where+    insert pool body parentId =+      runDb+        pool+        ( Insert.insert+            @CommentTable+            @CommentRow+            (CommentCreate {id = Nothing, parentId, body})+        )+        >>= assertRight
+ test/Poppy/DbSpec.hs view
@@ -0,0 +1,71 @@+module Poppy.DbSpec+  ( dbSpec,+  )+where++import Control.Exception (bracket)+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text as T+import Database.PostgreSQL.Simple.FromRow (FromRow (..), field)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy (DbPool, PoolConfig (..), closePool, connectWith, defaultPool, runDb)+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Query (matching)+import Poppy.Internal.Sql (executeRaw, param, queryRaw)+import Poppy.Internal.Where (eq)+import Schema.Widget (WidgetTable, widgetName)+import Support.TestDb (TestEnv, testDatabaseUrl)+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)++data CountRow = CountRow {cnt :: Int64}+  deriving (Eq, Show)++instance FromRow CountRow where+  fromRow = CountRow <$> field++withCustomPool :: PoolConfig -> (DbPool -> IO a) -> IO a+withCustomPool config action = do+  url <- testDatabaseUrl+  bracket (connectWith config url) closePool action++dbSpec :: SpecWith TestEnv+dbSpec =+  describe "Poppy.Internal.Db pool config" $ do+    it "connectWith a one-connection pool still runs a query" $ \_ ->+      withCustomPool defaultPool {poolStripes = 1, poolMaxPerStripe = 1} $ \pool -> do+        rows <-+          runDb pool $+            queryRaw @CountRow (Query "SELECT 1 AS cnt") []+        rows `shouldBe` [CountRow 1]++    it "sql log hook receives the assembled statement with parameters redacted" $ \_ -> do+      logs <- newIORef []+      let config =+            defaultPool+              { poolStripes = 1,+                poolMaxPerStripe = 1,+                poolSqlLog = \sql -> modifyIORef' logs (sql :)+              }+      withCustomPool config $ \pool -> do+        _ <-+          runDb pool $+            queryRaw @CountRow+              (Query "SELECT COUNT(*) AS cnt FROM test_widget WHERE name = ?")+              [param ("redacted-param" :: Text)]+        _ <-+          runDb pool $+            executeRaw+              (Query "UPDATE test_widget SET name = name WHERE name = ?")+              [param ("redacted-param" :: Text)]+        _ <- runDb pool (Ops.count @WidgetTable $ matching (eq widgetName "redacted-param"))+        pure ()+      recorded <- reverse <$> readIORef logs+      recorded+        `shouldSatisfy` any (T.isInfixOf "SELECT COUNT(*) AS cnt FROM test_widget WHERE name = ?")+      recorded+        `shouldSatisfy` any (T.isInfixOf "UPDATE test_widget SET name = name WHERE name = ?")+      recorded+        `shouldSatisfy` any (T.isInfixOf "SELECT COUNT(*) FROM \"test_widget\"")+      recorded `shouldSatisfy` all (not . T.isInfixOf "redacted-param")
+ test/Poppy/EnumSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TypeApplications #-}++module Poppy.EnumSpec+  ( enumSpec,+  )+where++import Poppy (runDb)+import qualified Poppy.AuthorFixtures as AuthorFixtures+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Query (matching)+import Poppy.Internal.Where (eq)+import Schema.Author (AuthorRow (..))+import Schema.Post (PostRow (..), PostTable, postStatus)+import Schema.PostStatus (PostStatus (..), postStatusToString)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldMatchList)++enumSpec :: SpecWith TestEnv+enumSpec =+  describe "schema enums" $ do+    it "maps constructors to Postgres labels" $ \_ -> do+      postStatusToString Draft `shouldBe` "draft"+      postStatusToString Published `shouldBe` "published"++    it "inserts and reads enum columns through FromField/ToField" $ \TestEnv {envPool = pool} -> do+      author <- AuthorFixtures.insertAuthor pool "Ada"+      draft <- AuthorFixtures.insertPost pool author.id "Notes" Draft+      published <- AuthorFixtures.insertPost pool author.id "Essay" Published+      draft.status `shouldBe` Draft+      published.status `shouldBe` Published+      rows <- runDb pool (Ops.findMany @PostTable @PostRow id)+      map (.status) rows `shouldMatchList` [Draft, Published]++    it "filters on an enum field" $ \TestEnv {envPool = pool} -> do+      author <- AuthorFixtures.insertAuthor pool "Ada"+      _ <- AuthorFixtures.insertPost pool author.id "Notes" Draft+      _ <- AuthorFixtures.insertPost pool author.id "Essay" Published+      rows <-+        runDb pool (Ops.findMany @PostTable @PostRow (matching (eq postStatus Published)))+      map (.title) rows `shouldBe` ["Essay"]+      map (.status) rows `shouldBe` [Published]
+ test/Poppy/ErrorsSpec.hs view
@@ -0,0 +1,67 @@+module Poppy.ErrorsSpec+  ( errorsSpec,+  )+where++import Data.ByteString (ByteString)+import Database.PostgreSQL.Simple (SqlError (..))+import Poppy.Internal.Errors (DatabaseErrorInfo (..), ORMError (..))+import Poppy.Internal.Sql (fromSqlError, quoteIdent)+import Test.Hspec (Spec, describe, it, shouldBe)++errorsSpec :: Spec+errorsSpec = do+  describe "Poppy.Internal.Sql.fromSqlError" $ do+    it "maps unique violations to UniqueViolation" $ do+      fromSqlError sampleUniqueError+        `shouldBe` UniqueViolation "duplicate key value violates unique constraint"++    it "maps foreign key violations to ForeignKeyViolation" $ do+      fromSqlError sampleFkError+        `shouldBe` ForeignKeyViolation "insert or update on table violates foreign key constraint"++    it "maps not-null violations to NotNullViolation" $ do+      fromSqlError sampleNotNullError+        `shouldBe` NotNullViolation "null value in column violates not-null constraint"++    it "maps other sql errors to DatabaseError" $ do+      fromSqlError sampleOtherError+        `shouldBe` DatabaseError+          DatabaseErrorInfo+            { sqlState = "08006",+              message = "connection failure",+              detail = ""+            }++  describe "Poppy.Internal.Sql.quoteIdent" $ do+    it "double-quotes identifiers" $+      quoteIdent "recipe" `shouldBe` "\"recipe\""++    it "escapes embedded quotes" $+      quoteIdent "a\"b" `shouldBe` "\"a\"\"b\""++sampleUniqueError :: SqlError+sampleUniqueError =+  sampleSqlError "23505" "duplicate key value violates unique constraint"++sampleFkError :: SqlError+sampleFkError =+  sampleSqlError "23503" "insert or update on table violates foreign key constraint"++sampleNotNullError :: SqlError+sampleNotNullError =+  sampleSqlError "23502" "null value in column violates not-null constraint"++sampleOtherError :: SqlError+sampleOtherError =+  sampleSqlError "08006" "connection failure"++sampleSqlError :: ByteString -> ByteString -> SqlError+sampleSqlError state msg =+  SqlError+    { sqlState = state,+      sqlExecStatus = toEnum 0,+      sqlErrorMsg = msg,+      sqlErrorDetail = "",+      sqlErrorHint = ""+    }
+ test/Poppy/GroupSpec.hs view
@@ -0,0 +1,20 @@+module Poppy.GroupSpec+  ( groupSpec,+  )+where++import Poppy.Internal.Group (groupByKey)+import Test.Hspec (Spec, describe, it, shouldBe)++groupSpec :: Spec+groupSpec =+  describe "Poppy.Internal.Group.groupByKey" $ do+    it "preserves first-seen key order rather than sorted key order" $ do+      groupByKey id ([3, 1, 3, 2, 1] :: [Int]) `shouldBe` [[3, 3], [1, 1], [2]]++    it "preserves row order within each group" $ do+      groupByKey fst ([('b', 1), ('a', 2), ('b', 3), ('a', 4)] :: [(Char, Int)])+        `shouldBe` [[('b', 1), ('b', 3)], [('a', 2), ('a', 4)]]++    it "returns an empty list for no rows" $ do+      groupByKey id ([] :: [Int]) `shouldBe` []
+ test/Poppy/IncludeFailSpec.hs view
@@ -0,0 +1,56 @@+module Poppy.IncludeFailSpec+  ( includeFailSpec,+  )+where++import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Hspec++includeFailSpec :: Spec+includeFailSpec =+  describe "include type errors" $ do+    it "says a skipped field is NotIncluded rather than the row list" $ do+      err <- expectFail "include-fail/SkippedChapters.hs"+      err `shouldContain` "NotIncluded"+      err `shouldContain` "[ChapterRow]"+      hidden <- expectFail "include-fail/SkippedChaptersNoSelectors.hs"+      hidden `shouldContain` "NotIncluded"+      hidden `shouldContain` "[ChapterRow]"++    it "rejects a shelf include nested under books" $ do+      err <- expectFail "include-fail/WrongChild.hs"+      err `shouldContain` "IncludeFor"+      err `shouldContain` "\"Book\""+      err `shouldContain` "ShelfInclude"++    it "rejects a record update when another record in scope shares the field" $ do+      err <- expectFail "include-fail/RecordUpdateAmbiguous.hs"+      err `shouldContain` "mbiguous"++expectFail :: FilePath -> IO String+expectFail path = do+  (code, _, err) <-+    readProcessWithExitCode+      "cabal"+      ( ["exec", "--", "ghc", "-package", "poppy", "-fno-code", "-w", "-itest", "-outputdir", "/tmp/poppy-include-fail"]+          ++ extensions+          ++ [path]+      )+      ""+  case code of+    ExitSuccess -> expectationFailure ("expected " <> path <> " to fail") >> pure err+    _ -> pure err++extensions :: [String]+extensions =+  [ "-XAllowAmbiguousTypes",+    "-XDuplicateRecordFields",+    "-XLambdaCase",+    "-XNamedFieldPuns",+    "-XOverloadedRecordDot",+    "-XOverloadedStrings",+    "-XScopedTypeVariables",+    "-XTypeApplications",+    "-XTypeFamilies"+  ]
+ test/Poppy/IncludeSpec.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-}++module Poppy.IncludeSpec+  ( includeSpec,+  )+where++import Data.List (sort)+import Data.Text (Text)+import qualified Data.Text as T+import Data.UUID (UUID, nil)+import GHC.Records (HasField)+import Poppy (asc, desc, load, loadWith, runDb, skip)+import Poppy.Internal.Include (Load (..))+import Poppy.IncludeUpdate (updatedChapters)+import qualified Poppy.Internal.Operations as Ops+import qualified Poppy.ShelfFixtures as ShelfFixtures+import Poppy.Internal.Where (eq, neq)+import Schema.Book (BookRow (..), bookId, bookTitle)+import Schema.Chapter (ChapterRow (..))+import qualified Schema.Client.Book as Book+import qualified Schema.Client.Shelf as Shelf+import Schema.Include.Book (BookInclude (..), BookWith (..))+import Schema.Include.Chapter (ChapterInclude (..), ChapterWith (..))+import Schema.Include.Shelf (ShelfInclude (..), ShelfWith (..))+import Schema.Section (SectionRow (..))+import Schema.Shelf (ShelfRow (..), ShelfTable, shelfName)+import Schema.Tag (TagRow (..))+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe)++includeBooks =+  ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = skip}++includeBooksChapters =+  ShelfInclude+    { books = loadWith (BookInclude {chapters = loadWith (ChapterInclude {sections = skip})}),+      tags = skip+    }++includeBooksAndTags =+  ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = load}++includeBooksChaptersAndTags =+  ShelfInclude+    { books = loadWith (BookInclude {chapters = loadWith (ChapterInclude {sections = skip})}),+      tags = load+    }++includeBooksChaptersSections =+  ShelfInclude+    { books = loadWith (BookInclude {chapters = loadWith (ChapterInclude {sections = load})}),+      tags = skip+    }++shelves include = Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = include})++shelvesWhere include predicate =+  Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = include, Shelf.where_ = Just predicate})++shelfById include pk =+  Shelf.findUnique ((Shelf.uniqueQuery (Shelf.ById pk)) {Shelf.include_ = include})++includeSpec :: SpecWith TestEnv+includeSpec =+  describe "Poppy.Internal.Include" $ do+    it "findMany nests books under their shelf" $ \TestEnv {envPool = pool} -> do+      fiction <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertShelf pool "nonfiction"+      _ <- ShelfFixtures.insertBook pool fiction.id "Dune"+      _ <- ShelfFixtures.insertBook pool fiction.id "Neuromancer"+      results <- runDb pool (shelves includeBooks)+      length results `shouldBe` 2+      fictionResult <- lookupShelf fiction.id results+      let bookIds = map ((.id) . (.book)) fictionResult.books+      bookIds `shouldBe` sort bookIds+      sort (map ((.title) . (.book)) fictionResult.books) `shouldBe` ["Dune", "Neuromancer"]++    it "findMany includes a shelf with no books as empty list" $ \TestEnv {envPool = pool} -> do+      empty <- ShelfFixtures.insertShelf pool "empty"+      stocked <- ShelfFixtures.insertShelf pool "stocked"+      _ <- ShelfFixtures.insertBook pool stocked.id "Book"+      results <- runDb pool (shelves includeBooks)+      emptyResult <- lookupShelf empty.id results+      length emptyResult.books `shouldBe` 0++    it "findMany without include uses single-table read" $ \TestEnv {envPool = pool} -> do+      _ <- ShelfFixtures.insertShelf pool "alpha"+      _ <- ShelfFixtures.insertShelf pool "beta"+      results <- runDb pool (Ops.findMany @ShelfTable @ShelfRow id)+      length results `shouldBe` 2+      sort (map (.name) results) `shouldBe` ["alpha", "beta"]++    it "findMany returns included roots in primary-key order" $ \TestEnv {envPool = pool} -> do+      firstShelf <- ShelfFixtures.insertShelf pool "first"+      secondShelf <- ShelfFixtures.insertShelf pool "second"+      results <- runDb pool (shelves includeBooks)+      map ((.id) . (.shelf)) results `shouldBe` sort [firstShelf.id, secondShelf.id]++    it "findMany applies root filter before nesting" $ \TestEnv {envPool = pool} -> do+      fiction <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertShelf pool "nonfiction"+      _ <- ShelfFixtures.insertBook pool fiction.id "Dune"+      results <-+        runDb pool (shelvesWhere includeBooks (eq shelfName "fiction"))+      length results `shouldBe` 1+      (head results).shelf.name `shouldBe` "fiction"+      map ((.title) . (.book)) (head results).books `shouldBe` ["Dune"]++    it "findMany nests chapters under books" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      book <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertChapter pool book.id "Arrakis"+      _ <- ShelfFixtures.insertChapter pool book.id "Caladan"+      results <- runDb pool (shelves includeBooksChapters)+      [result] <- pure results+      result.shelf.name `shouldBe` "fiction"+      [bookWithChapters] <- pure result.books+      (.title) bookWithChapters.book `shouldBe` "Dune"+      let chapterIds = map ((.id) . (.chapter)) bookWithChapters.chapters+      chapterIds `shouldBe` sort chapterIds+      sort (map ((.heading) . (.chapter)) bookWithChapters.chapters) `shouldBe` ["Arrakis", "Caladan"]++    it "findMany includes a book with no chapters as empty list" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      book <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer"+      _ <- ShelfFixtures.insertChapter pool book.id "Chiba"+      results <- runDb pool (shelves includeBooksChapters)+      [result] <- pure results+      dune <- lookupBook "Dune" result+      neuromancer <- lookupBook "Neuromancer" result+      map ((.heading) . (.chapter)) dune.chapters `shouldBe` ["Chiba"]+      length neuromancer.chapters `shouldBe` 0++    it "findMany returns all nested results" $ \TestEnv {envPool = pool} -> do+      _ <- ShelfFixtures.insertShelf pool "one"+      _ <- ShelfFixtures.insertShelf pool "two"+      results <- runDb pool (shelves includeBooks)+      length results `shouldBe` 2++    it "findUnique returns Just for an existing primary key" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertBook pool shelf.id "Dune"+      Right result <- runDb pool (shelfById includeBooks shelf.id)+      fmap ((.name) . (.shelf)) result `shouldBe` Just "fiction"++    it "findUnique returns all children for a parent with several has-many rows" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer"+      Right result <- runDb pool (shelfById includeBooks shelf.id)+      let bookIds = maybe [] (map ((.id) . (.book)) . (.books)) result+      bookIds `shouldBe` sort bookIds+      fmap (sort . map ((.title) . (.book)) . (.books)) result+        `shouldBe` Just ["Dune", "Neuromancer"]++    it "findUnique includes a shelf with no books as Just with an empty list" $ \TestEnv {envPool = pool} -> do+      empty <- ShelfFixtures.insertShelf pool "empty"+      Right result <- runDb pool (shelfById includeBooks empty.id)+      fmap ((.name) . (.shelf)) result `shouldBe` Just "empty"+      fmap (length . (.books)) result `shouldBe` Just 0++    it "findUnique returns Nothing when missing" $ \TestEnv {envPool = pool} -> do+      Right result <- runDb pool (shelfById includeBooks (nil :: UUID))+      case result of+        Nothing -> pure ()+        Just _ -> fail "expected Nothing"++    it "findMany with include paginates parent rows" $ \TestEnv {envPool = pool} -> do+      mapM_ (\n -> ShelfFixtures.insertShelf pool ("shelf-" `T.append` T.pack (show n))) ([1 .. 12] :: [Int])+      results <-+        runDb+          pool+          (Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = includeBooks, Shelf.limit_ = Just 10}))+      length results `shouldBe` 10++    it "findMany with include applies offset to parent rows" $ \TestEnv {envPool = pool} -> do+      _ <- ShelfFixtures.insertShelf pool "alpha"+      _ <- ShelfFixtures.insertShelf pool "bravo"+      _ <- ShelfFixtures.insertShelf pool "charlie"+      results <-+        runDb+          pool+          ( Shelf.findMany+              Shelf.emptyQuery+                { Shelf.include_ = includeBooks,+                  Shelf.orderBy_ = [asc shelfName],+                  Shelf.limit_ = Just 1,+                  Shelf.offset_ = Just 1+                }+          )+      length results `shouldBe` 1+      (head results).shelf.name `shouldBe` "bravo"++    it "findMany with include orders parent rows" $ \TestEnv {envPool = pool} -> do+      _ <- ShelfFixtures.insertShelf pool "zeta"+      _ <- ShelfFixtures.insertShelf pool "alpha"+      results <-+        runDb+          pool+          (Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = includeBooks, Shelf.orderBy_ = [asc shelfName]}))+      map ((.name) . (.shelf)) results `shouldBe` ["alpha", "zeta"]++    it "findMany loads sibling hasMany collections independently" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer"+      _ <- ShelfFixtures.insertTag pool shelf.id "scifi"+      _ <- ShelfFixtures.insertTag pool shelf.id "classic"+      results <- runDb pool (shelves includeBooksAndTags)+      [result] <- pure results+      sort (map ((.title) . (.book)) result.books) `shouldBe` ["Dune", "Neuromancer"]+      sort (map (.label) result.tags) `shouldBe` ["classic", "scifi"]++    it "findMany combines nested books with sibling tags" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      book <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertChapter pool book.id "Arrakis"+      _ <- ShelfFixtures.insertTag pool shelf.id "scifi"+      results <- runDb pool (shelves includeBooksChaptersAndTags)+      [result] <- pure results+      [bookWithChapters] <- pure result.books+      (.title) bookWithChapters.book `shouldBe` "Dune"+      map ((.heading) . (.chapter)) bookWithChapters.chapters `shouldBe` ["Arrakis"]+      map (.label) result.tags `shouldBe` ["scifi"]++    it "findMany nests sections under chapters at four levels deep" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      book <- ShelfFixtures.insertBook pool shelf.id "Dune"+      chapter <- ShelfFixtures.insertChapter pool book.id "Arrakis"+      _ <- ShelfFixtures.insertSection pool chapter.id "Desert"+      _ <- ShelfFixtures.insertSection pool chapter.id "Sietch"+      results <- runDb pool (shelves includeBooksChaptersSections)+      [result] <- pure results+      [bookWithChapters] <- pure result.books+      [chapterWithSections] <- pure bookWithChapters.chapters+      let sectionIds = map (.id) chapterWithSections.sections+      sectionIds `shouldBe` sort sectionIds+      sort (map (.label) chapterWithSections.sections) `shouldBe` ["Desert", "Sietch"]++    it "one renderer accepts a book loaded on its own and under a shelf" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      book <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertChapter pool book.id "Arrakis"+      let bookInclude = BookInclude {chapters = load}+      [fromBook] <-+        runDb+          pool+          (Book.findMany (Book.emptyQuery {Book.include_ = bookInclude, Book.where_ = Just (eq bookId book.id)}))+      [fromShelf] <-+        runDb+          pool+          (shelves (ShelfInclude {books = loadWith bookInclude, tags = skip}))+      renderBook fromBook `shouldBe` ["Arrakis"]+      renderBook (head fromShelf.books) `shouldBe` ["Arrakis"]++    it "updates a book include from the caller when the field name is unique" $ \_ ->+      updatedChapters `shouldBe` load++    it "findMany includes only books matching where_" $ \TestEnv {envPool = pool} -> do+      fiction <- ShelfFixtures.insertShelf pool "fiction"+      mystery <- ShelfFixtures.insertShelf pool "mystery"+      _ <- ShelfFixtures.insertBook pool fiction.id "Dune"+      _ <- ShelfFixtures.insertBook pool fiction.id "Neuromancer"+      _ <- ShelfFixtures.insertBook pool mystery.id "Rebecca"+      let include =+            ShelfInclude+              { books =+                  (loadWith (BookInclude {chapters = skip}))+                    { where_ = Just (eq bookTitle "Dune")+                    },+                tags = skip+              }+      results <- runDb pool (shelves include)+      fictionResult <- lookupShelf fiction.id results+      mysteryResult <- lookupShelf mystery.id results+      map ((.title) . (.book)) fictionResult.books `shouldBe` ["Dune"]+      length mysteryResult.books `shouldBe` 0++    it "findMany orders included books" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer"+      _ <- ShelfFixtures.insertBook pool shelf.id "Dune"+      _ <- ShelfFixtures.insertBook pool shelf.id "Contact"+      let include =+            ShelfInclude+              { books =+                  (loadWith (BookInclude {chapters = skip}))+                    { orderBy_ = [desc bookTitle]+                    },+                tags = skip+              }+      results <- runDb pool (shelves include)+      [result] <- pure results+      map ((.title) . (.book)) result.books `shouldBe` ["Neuromancer", "Dune", "Contact"]++    it "findMany takes two ordered books per shelf" $ \TestEnv {envPool = pool} -> do+      empty <- ShelfFixtures.insertShelf pool "empty"+      fiction <- ShelfFixtures.insertShelf pool "fiction"+      history <- ShelfFixtures.insertShelf pool "history"+      mapM_ (ShelfFixtures.insertBook pool fiction.id) ["alpha", "bravo", "charlie", "zzz"]+      mapM_ (ShelfFixtures.insertBook pool history.id) ["m", "n", "zzz"]+      let include =+            ShelfInclude+              { books =+                  (loadWith (BookInclude {chapters = skip}))+                    { where_ = Just (neq bookTitle "zzz"),+                      orderBy_ = [asc bookTitle],+                      take_ = Just 2+                    },+                tags = skip+              }+      results <- runDb pool (shelves include)+      emptyResult <- lookupShelf empty.id results+      fictionResult <- lookupShelf fiction.id results+      historyResult <- lookupShelf history.id results+      length emptyResult.books `shouldBe` 0+      map ((.title) . (.book)) fictionResult.books `shouldBe` ["alpha", "bravo"]+      map ((.title) . (.book)) historyResult.books `shouldBe` ["m", "n"]++renderBook :: (HasField "chapters" row [ChapterRow]) => row -> [Text]+renderBook row = map (.heading) row.chapters++lookupShelf wanted results =+  case filter ((== wanted) . (.id) . (.shelf)) results of+    [shelf] -> pure shelf+    _ -> fail "expected exactly one shelf in results"++lookupBook title result =+  case filter ((== title) . (.title) . (.book)) result.books of+    [book] -> pure book+    _ -> fail "expected exactly one book in results"
+ test/Poppy/IncludeUpdate.hs view
@@ -0,0 +1,14 @@+module Poppy.IncludeUpdate+  ( updatedChapters,+  )+where++import Poppy (load, skip)+import Poppy.Internal.Include (Load)+import Schema.Chapter (ChapterTable)+import Schema.Include.Book (BookInclude (..))++updatedChapters :: Load ChapterTable ()+updatedChapters =+  let BookInclude {chapters} = BookInclude {chapters = skip} {chapters = load}+   in chapters
+ test/Poppy/MigrateSpec.hs view
@@ -0,0 +1,111 @@+module Poppy.MigrateSpec+  ( migrateSpec,+  )+where++import Control.Exception (bracket)+import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text.IO as TIO+import Data.UUID.V4 (nextRandom)+import Database.PostgreSQL.Simple (Only (..))+import qualified Database.PostgreSQL.Simple as PG+import Poppy (MigrateError (..), applyMigrations)+import Poppy.Internal.Db (DbPool, withConn)+import Support.TestDb (TestEnv (..))+import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removeDirectoryRecursive)+import System.FilePath ((</>))+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)++migrateSpec :: SpecWith TestEnv+migrateSpec =+  describe "Poppy.Internal.Migrate" $ do+    it "applies SQL files in name order and is a no-op on replay" $ \TestEnv {envPool = pool} ->+      withCleanProbe pool+        $ withMigrationDir+          [ ("notes.txt", "not sql"),+            ("002-add-label.sql", "ALTER TABLE _poppy_phase10_probe ADD COLUMN label TEXT;"),+            ("001-create.sql", "CREATE TABLE _poppy_phase10_probe (id INT PRIMARY KEY);")+          ]+        $ \dir -> do+          first <- applyMigrations pool dir+          first `shouldBe` Right ["001-create.sql", "002-add-label.sql"]+          columns <- probeColumns pool+          columns `shouldBe` 2+          second <- applyMigrations pool dir+          second `shouldBe` Right []+          probeColumns pool >>= (`shouldBe` 2)++    it "does not record a failed file" $ \TestEnv {envPool = pool} ->+      withCleanProbe pool+        $ withMigrationDir+          [ ("001-ok.sql", "CREATE TABLE _poppy_phase10_probe (id INT PRIMARY KEY);"),+            ("002-bad.sql", "SELECT * FROM definitely_not_a_poppy_migrate_table;")+          ]+        $ \dir -> do+          result <- applyMigrations pool dir+          result+            `shouldSatisfy` ( \case+                                Left (MigrateFailed "002-bad.sql" _) -> True+                                _ -> False+                            )+          recorded <- recordedNames pool+          recorded `shouldBe` ["001-ok.sql"]+          exists <- probeExists pool+          exists `shouldBe` True++    it "returns DirectoryError when the path is not a directory" $ \TestEnv {envPool = pool} -> do+      result <- applyMigrations pool "/definitely-not-a-poppy-migrate-dir"+      result+        `shouldSatisfy` ( \case+                            Left (MigrateDirectoryError _) -> True+                            _ -> False+                        )++withCleanProbe :: DbPool -> IO a -> IO a+withCleanProbe pool action = dropProbeState pool >> action <* dropProbeState pool++dropProbeState :: DbPool -> IO ()+dropProbeState pool =+  withConn pool $ \conn -> do+    _ <- PG.execute_ conn "DROP TABLE IF EXISTS _poppy_phase10_probe CASCADE"+    _ <- PG.execute_ conn "DROP TABLE IF EXISTS _poppy_migrations CASCADE"+    pure ()++withMigrationDir :: [(FilePath, Text)] -> (FilePath -> IO a) -> IO a+withMigrationDir files action = do+  tmp <- getTemporaryDirectory+  token <- nextRandom+  let dir = tmp </> ("poppy-migrate-" <> show token)+  bracket+    (createDirectoryIfMissing True dir >> pure dir)+    removeDirectoryRecursive+    ( \dir -> do+        mapM_ (\(name, body) -> TIO.writeFile (dir </> name) body) files+        action dir+    )++probeExists :: DbPool -> IO Bool+probeExists pool =+  withConn pool $ \conn -> do+    [Only exists] <-+      PG.query_+        conn+        "SELECT to_regclass('public._poppy_phase10_probe') IS NOT NULL"+    pure exists++probeColumns :: DbPool -> IO Int64+probeColumns pool =+  withConn pool $ \conn -> do+    [Only n] <-+      PG.query_+        conn+        "SELECT COUNT(*) FROM information_schema.columns \+        \WHERE table_schema = 'public' AND table_name = '_poppy_phase10_probe'"+    pure n++recordedNames :: DbPool -> IO [Text]+recordedNames pool =+  withConn pool $ \conn -> do+    rows <- PG.query_ conn "SELECT name FROM _poppy_migrations ORDER BY name"+    pure [name | Only name <- rows]
+ test/Poppy/NestedWriteSpec.hs view
@@ -0,0 +1,345 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Poppy.NestedWriteSpec+  ( nestedWriteSpec,+  )+where++import Data.List (sort)+import qualified Data.UUID.V4 as V4+import Poppy (NullableValue (Omit), ORMError (..), load, loadWith, runDb, skip)+import qualified Poppy.Internal.Operations as Ops+import Schema.Book (BookRow (..), BookTable, BookUpdate (..))+import qualified Schema.Client.Book as Book+import qualified Schema.Client.Comment as Comment+import qualified Schema.Client.Shelf as Shelf+import Schema.Comment (CommentRow (..), CommentTable)+import Schema.Include.Book (BookInclude (..), BookWith (..))+import Schema.Include.Shelf (ShelfInclude (..), ShelfWith (..))+import Schema.Shelf (ShelfRow (..), ShelfTable)+import Support.Assert (assertRight)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, expectationFailure, it, shouldBe, shouldMatchList)++nestedWriteSpec :: SpecWith TestEnv+nestedWriteSpec =+  describe "nested writes" $ do+    it "create inserts a parent and children in one transaction" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb+          pool+          ( Shelf.create+              Shelf.ShelfCreate+                { id = Nothing,+                  name = "fiction",+                  books =+                    [ Shelf.CreateBook {id = Nothing, title = "Dune"},+                      Shelf.CreateBook {id = Nothing, title = "Neuromancer"}+                    ],+                  tags = []+                }+          )+          >>= assertRight+      result.name `shouldBe` "fiction"+      books <- runDb pool (Ops.findMany @BookTable @BookRow id)+      sort (map (.title) books) `shouldBe` ["Dune", "Neuromancer"]++    it "replaceWith replaces all children" $ \TestEnv {envPool = pool} -> do+      created <-+        runDb+          pool+          ( Shelf.create+              Shelf.ShelfCreate+                { id = Nothing,+                  name = "fiction",+                  books =+                    [ Shelf.CreateBook {id = Nothing, title = "Dune"},+                      Shelf.CreateBook {id = Nothing, title = "Neuromancer"}+                    ],+                  tags = []+                }+          )+          >>= assertRight+      _ <-+        runDb+          pool+          ( Shelf.update+              (Shelf.ById created.id)+              Shelf.ShelfUpdate+                { name = Nothing,+                  books = Just (booksReplace [Shelf.CreateBook {id = Nothing, title = "Hyperion"}]),+                  tags = Nothing+                }+          )+          >>= assertRight+      books <- runDb pool (Ops.findMany @BookTable @BookRow id)+      map (.title) books `shouldBe` ["Hyperion"]++    it "create on update adds a child without wiping existing ones" $ \TestEnv {envPool = pool} -> do+      created <-+        runDb+          pool+          ( Shelf.create+              Shelf.ShelfCreate+                { id = Nothing,+                  name = "fiction",+                  books = [Shelf.CreateBook {id = Nothing, title = "Dune"}],+                  tags = []+                }+          )+          >>= assertRight+      _ <-+        runDb+          pool+          ( Shelf.update+              (Shelf.ById created.id)+              Shelf.ShelfUpdate+                { name = Nothing,+                  books = Just (booksCreate [Shelf.CreateBook {id = Nothing, title = "Neuromancer"}]),+                  tags = Nothing+                }+          )+          >>= assertRight+      remaining <- runDb pool (Ops.findMany @BookTable @BookRow id)+      sort (map (.title) remaining) `shouldBe` ["Dune", "Neuromancer"]++    it "delete removes a child by unique key" $ \TestEnv {envPool = pool} -> do+      created <-+        runDb+          pool+          ( Shelf.create+              Shelf.ShelfCreate+                { id = Nothing,+                  name = "fiction",+                  books =+                    [ Shelf.CreateBook {id = Nothing, title = "Dune"},+                      Shelf.CreateBook {id = Nothing, title = "Neuromancer"}+                    ],+                  tags = []+                }+          )+          >>= assertRight+      loaded <-+        runDb+          pool+          (Shelf.findUnique ((Shelf.uniqueQuery (Shelf.ById created.id)) {Shelf.include_ = shelfInclude}))+          >>= assertRight+      let duneId =+            case loaded of+              Nothing -> error "expected shelf"+              Just shelf ->+                head [b.book.id | b <- shelf.books, b.book.title == "Dune"]+      _ <-+        runDb+          pool+          ( Shelf.update+              (Shelf.ById created.id)+              Shelf.ShelfUpdate+                { name = Nothing,+                  books = Just (booksDelete [Book.ById duneId]),+                  tags = Nothing+                }+          )+          >>= assertRight+      remaining <- runDb pool (Ops.findMany @BookTable @BookRow id)+      map (.title) remaining `shouldBe` ["Neuromancer"]++    it "disconnect keeps the child and clears a nullable FK" $ \TestEnv {envPool = pool} -> do+      parent <-+        runDb+          pool+          ( Comment.create+              Comment.CommentCreate+                { id = Nothing,+                  parentId = Omit,+                  body = "parent",+                  replies = []+                }+          )+          >>= assertRight+      child <-+        runDb+          pool+          ( Comment.create+              Comment.CommentCreate+                { id = Nothing,+                  parentId = Omit,+                  body = "child",+                  replies = []+                }+          )+          >>= assertRight+      _ <-+        runDb+          pool+          ( Comment.update+              (Comment.ById parent.id)+              Comment.CommentUpdate+                { parentId = Omit,+                  body = Nothing,+                  replies = Just (repliesConnect [Comment.ById child.id])+                }+          )+          >>= assertRight+      _ <-+        runDb+          pool+          ( Comment.update+              (Comment.ById parent.id)+              Comment.CommentUpdate+                { parentId = Omit,+                  body = Nothing,+                  replies = Just (repliesDisconnect [Comment.ById child.id])+                }+          )+          >>= assertRight+      remaining <- runDb pool (Ops.findMany @CommentTable @CommentRow id)+      sort (map (.body) remaining) `shouldMatchList` ["child", "parent"]+      let childRow = head [c | c <- remaining, c.body == "child"]+      childRow.parentId `shouldBe` Nothing++    it "upsert does not steal another parent's child" $ \TestEnv {envPool = pool} -> do+      shelfA <-+        runDb+          pool+          ( Shelf.create+              Shelf.ShelfCreate+                { id = Nothing,+                  name = "a",+                  books = [Shelf.CreateBook {id = Nothing, title = "Owned"}],+                  tags = []+                }+          )+          >>= assertRight+      shelfB <-+        runDb+          pool+          ( Shelf.create+              Shelf.ShelfCreate {id = Nothing, name = "b", books = [], tags = []}+          )+          >>= assertRight+      owned <- runDb pool (Ops.findMany @BookTable @BookRow id)+      let bookId = head [b.id | b <- owned, b.title == "Owned"]+      result <-+        runDb+          pool+          ( Shelf.update+              (Shelf.ById shelfB.id)+              Shelf.ShelfUpdate+                { name = Nothing,+                  books =+                    Just+                      ( booksUpsert+                          [ Shelf.BookNestedUpsert+                              { where_ = Book.ById bookId,+                                create = Shelf.CreateBook {id = Nothing, title = "Stolen"},+                                update = BookUpdate {shelfId = Nothing, title = Just "Stolen"}+                              }+                          ]+                      ),+                  tags = Nothing+                }+          )+      case result of+        Left (UniqueViolation _) -> pure ()+        Left other -> expectationFailure ("expected UniqueViolation, got " <> show other)+        Right _ -> expectationFailure "expected UniqueViolation when upsert would reparent"+      remaining <- runDb pool (Ops.findMany @BookTable @BookRow id)+      map (.shelfId) remaining `shouldBe` [shelfA.id]+      map (.title) remaining `shouldBe` ["Owned"]++    it "create rolls back the parent when a child write fails" $ \TestEnv {envPool = pool} -> do+      fixed <- V4.nextRandom+      result <-+        runDb pool $+          Shelf.create+            Shelf.ShelfCreate+              { id = Nothing,+                name = "rollback",+                books =+                  [ Shelf.CreateBook {id = Just fixed, title = "Lost"},+                    Shelf.CreateBook {id = Just fixed, title = "Dup"}+                  ],+                tags = []+              }+      case result of+        Left (UniqueViolation _) -> pure ()+        Left other -> expectationFailure ("expected UniqueViolation, got " <> show other)+        Right _ -> expectationFailure "expected UniqueViolation, got a written shelf"+      shelves <- runDb pool (Ops.findMany @ShelfTable @ShelfRow id)+      books <- runDb pool (Ops.findMany @BookTable @BookRow id)+      shelves `shouldBe` []+      books `shouldBe` []++booksReplace xs =+  Shelf.BooksUpdate+    { replaceWith = Just xs,+      create = [],+      createMany = [],+      connect = [],+      delete = [],+      update = [],+      upsert = []+    }++booksCreate xs =+  Shelf.BooksUpdate+    { replaceWith = Nothing,+      create = xs,+      createMany = [],+      connect = [],+      delete = [],+      update = [],+      upsert = []+    }++booksDelete keys =+  Shelf.BooksUpdate+    { replaceWith = Nothing,+      create = [],+      createMany = [],+      connect = [],+      delete = keys,+      update = [],+      upsert = []+    }++booksUpsert items =+  Shelf.BooksUpdate+    { replaceWith = Nothing,+      create = [],+      createMany = [],+      connect = [],+      delete = [],+      update = [],+      upsert = items+    }++repliesConnect keys =+  Comment.RepliesUpdate+    { replaceWith = Nothing,+      create = [],+      createMany = [],+      connect = keys,+      delete = [],+      update = [],+      upsert = [],+      disconnect = []+    }++repliesDisconnect keys =+  Comment.RepliesUpdate+    { replaceWith = Nothing,+      create = [],+      createMany = [],+      connect = [],+      delete = [],+      update = [],+      upsert = [],+      disconnect = keys+    }++shelfInclude =+  ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = skip}
+ test/Poppy/OperationsSpec.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE LambdaCase #-}++module Poppy.OperationsSpec+  ( operationsSpec,+  )+where++import Data.List (sort)+import Data.UUID (UUID, nil)+import Poppy (NullableValue (..), ORMError (..), runDb)+import qualified Poppy.Internal.Delete as Delete+import qualified Poppy.Internal.Insert as Insert+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Query (OrderDirection (Asc), limit, matching, offset, orderBy)+import qualified Poppy.Internal.Update as Update+import Poppy.Internal.Where (contains, eq, in_, isNull, or_)+import qualified Poppy.WidgetFixtures as WidgetFixtures+import Schema.Book (BookCreate (..), BookRow (..), BookTable)+import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetTable (..), WidgetUpdate (..), widgetCreatedAt, widgetDescription, widgetId, widgetName)+import Support.Assert (assertJust, assertRight)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)++operationsSpec :: SpecWith TestEnv+operationsSpec =+  describe "Poppy.Internal.Operations" $ do+    it "findMany returns an empty list on a clean test_widget table" $ \TestEnv {envPool = pool} -> do+      rows <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id)+      rows `shouldBe` []++    it "findMany returns all rows in table" $ \TestEnv {envPool = pool} -> do+      alpha <- WidgetFixtures.insertWidget pool "alpha"+      beta <- WidgetFixtures.insertWidget pool "beta"+      gamma <- WidgetFixtures.insertWidget pool "gamma"+      results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id)+      sort (map (.id) results) `shouldBe` sort [alpha.id, beta.id, gamma.id]++    it "findUnique returns an element by id" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "test"+      result <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id)+      result `shouldBe` Just widget++    it "findMany returns all elements that pass the filter" $ \TestEnv {envPool = pool} -> do+      alpha1 <- insertDescribed pool "alpha-1" "pair"+      alpha2 <- insertDescribed pool "alpha-2" "pair"+      _ <- WidgetFixtures.insertWidget pool "beta"+      results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (eq widgetDescription "pair"))+      sort (map (.id) results) `shouldBe` sort [alpha1.id, alpha2.id]++    it "findUniqueOrFail returns an element by id" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "test"+      result <- runDb pool (Ops.findUniqueOrFail @WidgetTable @WidgetRow widget.id)+      result `shouldBe` Right widget++    it "findUniqueOrFail returns an error if no element is found" $ \TestEnv {envPool = pool} -> do+      result <- runDb pool (Ops.findUniqueOrFail @WidgetTable @WidgetRow (nil :: UUID))+      result+        `shouldSatisfy` ( \case+                            Left (RecordNotFound _) -> True+                            _ -> False+                        )++    it "findFirst returns the first element that passes the filter" $ \TestEnv {envPool = pool} -> do+      alpha1 <- insertDescribed pool "alpha-1" "pair"+      alpha2 <- insertDescribed pool "alpha-2" "pair"+      _ <- WidgetFixtures.insertWidget pool "beta"+      result <- runDb pool (Ops.findFirst @WidgetTable @WidgetRow $ matching (eq widgetDescription "pair"))+      row <- assertJust result+      row.description `shouldBe` Just "pair"+      row.id `shouldSatisfy` (`elem` [alpha1.id, alpha2.id])++    it "findFirst returns Nothing when no row matches" $ \TestEnv {envPool = pool} -> do+      result <- runDb pool (Ops.findFirst @WidgetTable @WidgetRow $ matching (eq widgetName "nonexistent"))+      result `shouldBe` Nothing++    it "count returns the number of rows matching a filter" $ \TestEnv {envPool = pool} -> do+      _ <- insertDescribed pool "alpha-1" "pair"+      _ <- insertDescribed pool "alpha-2" "pair"+      _ <- WidgetFixtures.insertWidget pool "beta"+      n <- runDb pool (Ops.count @WidgetTable $ matching (eq widgetDescription "pair"))+      n `shouldBe` 2++    it "count returns 0 when no rows match" $ \TestEnv {envPool = pool} -> do+      n <- runDb pool (Ops.count @WidgetTable $ matching (eq widgetName "nonexistent"))+      n `shouldBe` 0++    it "update changes a widget name by id" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "before"+      updated <-+        runDb+          pool+          ( Update.update @WidgetTable @WidgetRow+              widget.id+              WidgetUpdate+                { name = Just "after",+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  description = Omit+                }+          )+          >>= assertRight+      updated.name `shouldBe` "after"+      found <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id)+      found `shouldBe` Just updated++    it "update with Omit leaves description unchanged" $ \TestEnv {envPool = pool} -> do+      widget <-+        runDb+          pool+          ( Insert.insert @WidgetTable @WidgetRow+              WidgetCreate+                { id = Nothing,+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  name = "widget",+                  description = Value "keep me"+                }+          )+          >>= assertRight+      updated <-+        runDb+          pool+          ( Update.update @WidgetTable @WidgetRow+              widget.id+              WidgetUpdate+                { name = Just "renamed",+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  description = Omit+                }+          )+          >>= assertRight+      updated.name `shouldBe` "renamed"+      updated.description `shouldBe` Just "keep me"++    it "insert with Null sets description to NULL" $ \TestEnv {envPool = pool} -> do+      widget <-+        runDb+          pool+          ( Insert.insert @WidgetTable @WidgetRow+              WidgetCreate+                { id = Nothing,+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  name = "widget",+                  description = Null+                }+          )+          >>= assertRight+      widget.description `shouldBe` Nothing++    it "update with Null clears description" $ \TestEnv {envPool = pool} -> do+      widget <-+        runDb+          pool+          ( Insert.insert @WidgetTable @WidgetRow+              WidgetCreate+                { id = Nothing,+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  name = "widget",+                  description = Value "keep me"+                }+          )+          >>= assertRight+      updated <-+        runDb+          pool+          ( Update.update @WidgetTable @WidgetRow+              widget.id+              WidgetUpdate+                { name = Nothing,+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  description = Null+                }+          )+          >>= assertRight+      updated.description `shouldBe` Nothing++    it "findMany supports offset" $ \TestEnv {envPool = pool} -> do+      _ <- insertDescribed pool "alpha-1" "page"+      _ <- insertDescribed pool "alpha-2" "page"+      _ <- insertDescribed pool "alpha-3" "page"+      allAlpha <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (eq widgetDescription "page"))+      paged <-+        runDb+          pool+          ( Ops.findMany @WidgetTable @WidgetRow $+              offset 1 . limit 1 . orderBy widgetCreatedAt Asc . matching (eq widgetDescription "page")+          )+      length allAlpha `shouldBe` 3+      length paged `shouldBe` 1++    it "delete removes a widget by id" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "doomed"+      deleted <- runDb pool (Ops.delete @WidgetTable widget.id) >>= assertRight+      deleted `shouldBe` 1+      found <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id)+      found `shouldBe` Nothing++    it "delete returns 0 when no row matches" $ \TestEnv {envPool = pool} -> do+      deleted <- runDb pool (Ops.delete @WidgetTable (nil :: UUID)) >>= assertRight+      deleted `shouldBe` 0++    it "deleteWhere without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do+      result <- runDb pool (Delete.deleteWhere (Delete.emptyDelete @WidgetTable))+      result+        `shouldSatisfy` ( \case+                            Left (EmptyWhere _) -> True+                            _ -> False+                        )++    it "deleteReturning without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb+          pool+          (Delete.deleteReturning @WidgetTable @WidgetRow (Delete.emptyDelete @WidgetTable))+      result+        `shouldSatisfy` ( \case+                            Left (EmptyWhere _) -> True+                            _ -> False+                        )++    it "updateReturning without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb+          pool+          ( Update.updateReturning @WidgetTable @WidgetRow $+              Update.setField widgetName "x" (Update.emptyUpdate @WidgetTable)+          )+      result+        `shouldSatisfy` ( \case+                            Left (EmptyWhere _) -> True+                            _ -> False+                        )++    it "deleteMany removes rows matching a Where predicate" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "doomed"+      _ <- WidgetFixtures.insertWidget pool "keep"+      deleted <- runDb pool (Delete.deleteMany @WidgetTable (eq widgetName "doomed")) >>= assertRight+      deleted `shouldBe` 1+      remaining <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id)+      map (.name) remaining `shouldBe` ["keep"]++    it "findMany contains matches a substring case-insensitively" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "Sea Salt"+      _ <- WidgetFixtures.insertWidget pool "pepper"+      results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (contains widgetName "salt"))+      map (.name) results `shouldBe` ["Sea Salt"]++    it "findMany isNull matches NULL description" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "blank"+      results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (isNull widgetDescription))+      map (.id) results `shouldBe` [widget.id]++    it "findMany in_ matches any listed value" $ \TestEnv {envPool = pool} -> do+      alpha <- WidgetFixtures.insertWidget pool "alpha"+      _ <- WidgetFixtures.insertWidget pool "beta"+      gamma <- WidgetFixtures.insertWidget pool "gamma"+      results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (in_ widgetName ["alpha", "gamma"]))+      sort (map (.id) results) `shouldBe` sort [alpha.id, gamma.id]++    it "findMany in_ [] matches nothing" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "alpha"+      results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (in_ widgetName []))+      results `shouldBe` []++    it "findMany or_ combines predicates" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "alpha"+      _ <- WidgetFixtures.insertWidget pool "beta"+      _ <- WidgetFixtures.insertWidget pool "gamma"+      results <-+        runDb+          pool+          ( Ops.findMany @WidgetTable @WidgetRow $+              matching (eq widgetName "alpha" `or_` eq widgetName "gamma")+          )+      sort (map (.name) results) `shouldBe` ["alpha", "gamma"]++    it "updateBuilder without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb+          pool+          ( Update.updateBuilder @WidgetTable @WidgetRow $+              Update.setField widgetName "x" (Update.emptyUpdate @WidgetTable)+          )+      result+        `shouldSatisfy` ( \case+                            Left (EmptyWhere _) -> True+                            _ -> False+                        )++    it "insert maps not-null violations" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb+          pool+          ( Insert.insertBuilder @WidgetTable @WidgetRow $+              Insert.set widgetId nil (Insert.emptyInsert @WidgetTable)+          )+      result+        `shouldSatisfy` ( \case+                            Left (NotNullViolation _) -> True+                            _ -> False+                        )++    it "insert maps foreign key violations" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb+          pool+          ( Insert.insert @BookTable @BookRow+              BookCreate+                { id = Nothing,+                  shelfId = nil,+                  title = "ghost"+                }+          )+      result+        `shouldSatisfy` ( \case+                            Left (ForeignKeyViolation _) -> True+                            _ -> False+                        )++insertDescribed pool name description =+  runDb+    pool+    ( Insert.insert @WidgetTable @WidgetRow+        WidgetCreate+          { id = Nothing,+            createdAt = Nothing,+            updatedAt = Nothing,+            name,+            description = Value description+          }+    )+    >>= assertRight
+ test/Poppy/RawSpec.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Poppy.RawSpec+  ( rawSpec,+  )+where++import Control.Exception (ErrorCall (..), throwIO, try)+import Data.Int (Int64)+import Data.Text (Text)+import Database.PostgreSQL.Simple.FromRow (FromRow (..), field)+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy (NullableValue (Omit), ORMError (..), runDb, transaction, withTransaction)+import Poppy.Internal.Db (liftIO)+import qualified Poppy.Internal.Insert as Insert+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Sql (catchDb, executeRaw, param, queryRaw)+import qualified Poppy.WidgetFixtures as WidgetFixtures+import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetTable)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)++data CountRow = CountRow {cnt :: Int64}+  deriving (Eq, Show)++instance FromRow CountRow where+  fromRow = CountRow <$> field++rawSpec :: SpecWith TestEnv+rawSpec =+  describe "Poppy.Internal.Sql raw queries" $ do+    it "queryRaw returns typed rows" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "alpha"+      _ <- WidgetFixtures.insertWidget pool "beta"+      rows <-+        runDb pool $+          queryRaw+            (Query "SELECT COUNT(*) AS cnt FROM test_widget")+            []+      rows `shouldBe` [CountRow 2]++    it "queryRaw binds parameters" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "needle"+      _ <- WidgetFixtures.insertWidget pool "hay"+      rows <-+        runDb pool $+          queryRaw+            (Query "SELECT id, created_at, updated_at, name, description FROM test_widget WHERE name = ?")+            [param ("needle" :: Text)]+      rows `shouldBe` [widget]++    it "executeRaw updates rows" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "before"+      affected <-+        runDb pool $+          executeRaw+            (Query "UPDATE test_widget SET name = ? WHERE id = ?")+            [param ("after" :: Text), param widget.id]+      affected `shouldBe` 1+      updated <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id)+      fmap (.name) updated `shouldBe` Just "after"++    it "executeRaw changes are visible to subsequent reads within a transaction" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "tx-before"+      updated <-+        withTransaction pool $ do+          _ <-+            executeRaw+              (Query "UPDATE test_widget SET name = ? WHERE id = ?")+              [param ("tx-after" :: Text), param widget.id]+          Ops.findUnique @WidgetTable @WidgetRow widget.id+      fmap (.name) updated `shouldBe` Just "tx-after"+      persisted <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id)+      fmap (.name) persisted `shouldBe` Just "tx-after"++    it "queryRaw participates in withTransaction" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "shared-connection"+      (count, found) <-+        withTransaction pool $ do+          results <-+            queryRaw+              (Query "SELECT COUNT(*) AS cnt FROM test_widget WHERE id = ?")+              [param widget.id]+          row <- Ops.findUnique @WidgetTable @WidgetRow widget.id+          pure (results, row)+      count `shouldBe` [CountRow 1]+      found `shouldBe` Just widget++    it "catchDb maps SQL errors to ORMError" $ \TestEnv {envPool = pool} -> do+      result <-+        runDb pool $+          catchDb $+            queryRaw @WidgetRow+              (Query "SELECT * FROM definitely_not_a_real_table")+              []+      result+        `shouldSatisfy` ( \case+                            Left (DatabaseError _) -> True+                            _ -> False+                        )++    it "transaction commits on success" $ \TestEnv {envPool = pool} -> do+      inserted <-+        runDb pool $+          transaction $+            Insert.insert @WidgetTable @WidgetRow+              WidgetCreate+                { id = Nothing,+                  createdAt = Nothing,+                  updatedAt = Nothing,+                  name = "tx-commit",+                  description = Omit+                }+      inserted+        `shouldSatisfy` ( \case+                            Right row -> row.name == "tx-commit"+                            Left _ -> False+                        )+      rows <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id)+      length rows `shouldBe` 1++    it "transaction rolls back when the action throws" $ \TestEnv {envPool = pool} -> do+      _ <-+        try @ErrorCall $+          runDb pool $+            transaction $ do+              _ <-+                Insert.insert @WidgetTable @WidgetRow+                  WidgetCreate+                    { id = Nothing,+                      createdAt = Nothing,+                      updatedAt = Nothing,+                      name = "tx-rollback",+                      description = Omit+                    }+              liftIO $ throwIO (ErrorCall "boom")+      rows <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id)+      rows `shouldBe` []
+ test/Poppy/ScalarSpec.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Poppy.ScalarSpec+  ( scalarSpec,+  )+where++import Data.Aeson (object, (.=))+import Data.Scientific (scientific)+import Data.Text (Text)+import Poppy (runDb)+import qualified Poppy.Internal.Insert as Insert+import qualified Poppy.Internal.Operations as Ops+import Schema.Packet+import Support.Assert (assertRight)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe)++scalarSpec :: SpecWith TestEnv+scalarSpec =+  describe "numeric and jsonb scalars" $ do+    it "round-trips Scientific and aeson Value through insert and select" $ \TestEnv {envPool = pool} -> do+      let amount = scientific 1999 (-2)+          payload = object ["kind" .= ("box" :: Text), "n" .= (2 :: Int)]+      inserted <-+        runDb+          pool+          ( Insert.insert @PacketTable @PacketRow+              PacketCreate+                { id = Nothing,+                  amount,+                  payload+                }+          )+          >>= assertRight+      inserted.amount `shouldBe` amount+      inserted.payload `shouldBe` payload+      found <- runDb pool (Ops.findUnique @PacketTable @PacketRow inserted.id)+      found `shouldBe` Just inserted
+ test/Poppy/SelectSpec.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Poppy.SelectSpec+  ( selectSpec,+  )+where++import Poppy (ORMError (..), Picked (..), asc, desc, loadWith, runDb, skip)+import qualified Poppy.Internal.Operations as Ops+import Poppy.Internal.Query (selectColumns)+import Poppy.Internal.Select (picked)+import qualified Poppy.ShelfFixtures as ShelfFixtures+import Poppy.Internal.Where (eq)+import qualified Poppy.WidgetFixtures as WidgetFixtures+import Schema.Book (BookRow (..))+import qualified Schema.Client.Shelf as Shelf+import qualified Schema.Client.Widget as Widget+import Schema.Include.Book (BookInclude (..), BookWith (..))+import Schema.Include.Shelf (ShelfInclude (..), ShelfWith (..), ShelfWithPicked (..))+import Schema.Shelf (ShelfPicked (..), ShelfRow (..), shelfId, shelfName)+import Schema.Widget+  ( WidgetPicked (..),+    WidgetRow (..),+    WidgetSelect (..),+    WidgetTable,+    parseWidgetPicked,+    widgetCreatedAt,+    widgetName,+    widgetSelectColumns,+  )+import Support.Assert (assertRight)+import Support.TestDb (TestEnv (..))+import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)++selectSpec :: SpecWith TestEnv+selectSpec = do+  describe "Poppy.Internal.Select columns" $ do+    it "always includes the primary key and only requested scalars" $ \_ ->+      widgetSelectColumns+        WidgetSelect+          { id = False,+            createdAt = False,+            updatedAt = False,+            name = True,+            description = True+          }+        `shouldBe` ["id", "name", "description"]++    it "maps False fields to Skipped" $ \_ -> do+      picked False ("secret" :: String) `shouldBe` Skipped+      picked True ("shown" :: String) `shouldBe` Picked "shown"++  describe "single-table select_" $ do+    it "loads only requested widget columns into WidgetPicked" $ \TestEnv {envPool = pool} -> do+      widget <- WidgetFixtures.insertWidget pool "alpha"+      let sel =+            WidgetSelect+              { id = False,+                createdAt = False,+                updatedAt = False,+                name = True,+                description = False+              }+      [row] <-+        runDb pool $+          Ops.findManyWith @WidgetTable+            (parseWidgetPicked sel)+            (selectColumns (widgetSelectColumns sel))+      let WidgetRow {id = widgetId} = widget+          WidgetPicked {id = rowId, name = rowName, description = rowDescription, createdAt = rowCreatedAt, updatedAt = rowUpdatedAt} = row+      rowId `shouldBe` widgetId+      rowName `shouldBe` Picked "alpha"+      rowDescription `shouldBe` Skipped+      rowCreatedAt `shouldBe` Skipped+      rowUpdatedAt `shouldBe` Skipped++    it "keeps WidgetRow when select_ is OmitSelect" $ \TestEnv {envPool = pool} -> do+      created <- WidgetFixtures.insertWidget pool "salt"+      rows <- runDb pool (Widget.findMany Widget.emptyQuery)+      map (.name) rows `shouldBe` ["salt"]+      map (.id) rows `shouldBe` [created.id]++    it "findUnique looks up by primary key" $ \TestEnv {envPool = pool} -> do+      created <- WidgetFixtures.insertWidget pool "thyme"+      found <-+        runDb+          pool+          (Widget.findUnique (Widget.uniqueQuery (Widget.ById created.id)))+      found `shouldBe` Right (Just created)++    it "findUnique looks up by a declared unique" $ \TestEnv {envPool = pool} -> do+      created <- WidgetFixtures.insertWidget pool "sage"+      found <-+        runDb+          pool+          (Widget.findUnique (Widget.uniqueQuery (Widget.ByName "sage")))+      found `shouldBe` Right (Just created)++    it "findUnique projects columns when select_ is set" $ \TestEnv {envPool = pool} -> do+      created <- WidgetFixtures.insertWidget pool "basil"+      let sel =+            WidgetSelect+              { id = False,+                createdAt = False,+                updatedAt = False,+                name = True,+                description = False+              }+      found <-+        runDb+          pool+          (Widget.findUnique ((Widget.uniqueQuery (Widget.ById created.id)) {Widget.select_ = sel}))+          >>= assertRight+      fmap (.name) found `shouldBe` Just (Picked "basil")++    it "returns WidgetPicked when select_ is set" $ \TestEnv {envPool = pool} -> do+      created <- WidgetFixtures.insertWidget pool "pepper"+      let sel =+            WidgetSelect+              { id = False,+                createdAt = False,+                updatedAt = False,+                name = True,+                description = False+              }+          query :: Widget.WidgetQuery WidgetSelect+          query =+            Widget.WidgetQuery+              { select_ = sel,+                where_ = Nothing,+                orderBy_ = [],+                limit_ = Nothing,+                offset_ = Nothing+              }+      [row] <- runDb pool (Widget.findMany query)+      row.id `shouldBe` created.id+      row.name `shouldBe` Picked "pepper"+      row.createdAt `shouldBe` Skipped+      row.updatedAt `shouldBe` Skipped++    it "findMany orderBy_ sorts by listed fields" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "beta"+      _ <- WidgetFixtures.insertWidget pool "alpha"+      _ <- WidgetFixtures.insertWidget pool "gamma"+      ascending <-+        runDb+          pool+          (Widget.findMany Widget.emptyQuery {Widget.orderBy_ = [asc widgetName]})+      descending <-+        runDb+          pool+          (Widget.findMany Widget.emptyQuery {Widget.orderBy_ = [desc widgetName]})+      multi <-+        runDb+          pool+          ( Widget.findMany+              Widget.emptyQuery {Widget.orderBy_ = [asc widgetName, desc widgetCreatedAt]}+          )+      map (.name) ascending `shouldBe` ["alpha", "beta", "gamma"]+      map (.name) descending `shouldBe` ["gamma", "beta", "alpha"]+      map (.name) multi `shouldBe` ["alpha", "beta", "gamma"]++    it "count and findFirst use the generated Client" $ \TestEnv {envPool = pool} -> do+      _ <- WidgetFixtures.insertWidget pool "beta"+      alpha <- WidgetFixtures.insertWidget pool "alpha"+      n <- runDb pool (Widget.count Widget.emptyQuery {Widget.where_ = Just (eq widgetName "alpha")})+      n `shouldBe` 1+      firstAsc <-+        runDb+          pool+          ( Widget.findFirst+              Widget.emptyQuery {Widget.orderBy_ = [asc widgetName]}+          )+      firstAsc `shouldBe` Just alpha+      missing <-+        runDb+          pool+          ( Widget.findFirstOrFail+              Widget.emptyQuery {Widget.where_ = Just (eq widgetName "missing")}+          )+      missing+        `shouldSatisfy` ( \case+                            Left (RecordNotFound _) -> True+                            _ -> False+                        )++  describe "select_ + include" $ do+    it "projects shelf scalars and keeps nested books" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "fiction"+      _ <- ShelfFixtures.insertBook pool shelf.id "Dune"+      let sel =+            Shelf.ShelfSelect+              { id = False,+                name = True+              }+          query =+            Shelf.ShelfQuery+              { include_ = shelfInclude,+                select_ = sel,+                where_ = Just (eq shelfName "fiction"),+                orderBy_ = [],+                limit_ = Nothing,+                offset_ = Nothing+              }+      [row] <- runDb pool (Shelf.findMany query)+      row.shelf.id `shouldBe` shelf.id+      row.shelf.name `shouldBe` Picked "fiction"+      length row.books `shouldBe` 1+      (head row.books).book.title `shouldBe` "Dune"++    it "findMany emptyQuery returns ShelfRow without include_" $ \TestEnv {envPool = pool} -> do+      created <- ShelfFixtures.insertShelf pool "Toast"+      rows <- runDb pool (Shelf.findMany Shelf.emptyQuery)+      map (.name) rows `shouldBe` ["Toast"]+      map (.id) rows `shouldBe` [created.id]+      found <-+        runDb+          pool+          (Shelf.findUnique (Shelf.uniqueQuery (Shelf.ById created.id)))+          >>= assertRight+      fmap (.name) found `shouldBe` Just "Toast"++    it "findUnique loads included relations" $ \TestEnv {envPool = pool} -> do+      shelf <- ShelfFixtures.insertShelf pool "Omelette"+      _ <- ShelfFixtures.insertBook pool shelf.id "Eggs"+      found <-+        runDb+          pool+          (Shelf.findUnique ((Shelf.uniqueQuery (Shelf.ById shelf.id)) {Shelf.include_ = shelfInclude}))+          >>= assertRight+      fmap (.shelf.name) found `shouldBe` Just "Omelette"+      fmap (length . (.books)) found `shouldBe` Just 1++    it "create and findMany share Schema.Client.Shelf" $ \TestEnv {envPool = pool} -> do+      created <-+        runDb pool (Shelf.create (Shelf.ShelfCreate {id = Nothing, name = "Pantry", books = [], tags = []}))+          >>= assertRight+      rows <-+        runDb+          pool+          ( Shelf.findMany+              Shelf.emptyQuery+                { Shelf.include_ = shelfInclude,+                  Shelf.where_ = Just (eq shelfId created.id)+                }+          )+      map ((.name) . (.shelf)) rows `shouldBe` ["Pantry"]+      map ((.id) . (.shelf)) rows `shouldBe` [created.id]++shelfInclude =+  ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = skip}
+ test/Poppy/ShelfFixtures.hs view
@@ -0,0 +1,45 @@+module Poppy.ShelfFixtures+  ( insertShelf,+    insertBook,+    insertChapter,+    insertSection,+    insertTag,+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy (runDb)+import Poppy.Internal.Db (DbPool)+import qualified Poppy.Internal.Insert as Insert+import Schema.Book (BookCreate (..), BookRow (..), BookTable)+import Schema.Chapter (ChapterCreate (..), ChapterRow (..), ChapterTable)+import Schema.Section (SectionCreate (..), SectionRow (..), SectionTable)+import Schema.Shelf (ShelfCreate (..), ShelfRow (..), ShelfTable)+import Schema.Tag (TagCreate (..), TagRow (..), TagTable)+import Support.Assert (assertRight)++insertShelf :: DbPool -> Text -> IO ShelfRow+insertShelf pool name =+  runDb pool (Insert.insert @ShelfTable @ShelfRow (ShelfCreate {id = Nothing, name}))+    >>= assertRight++insertBook :: DbPool -> UUID -> Text -> IO BookRow+insertBook pool shelfId title =+  runDb pool (Insert.insert @BookTable @BookRow (BookCreate {id = Nothing, shelfId, title}))+    >>= assertRight++insertChapter :: DbPool -> UUID -> Text -> IO ChapterRow+insertChapter pool bookRef heading =+  runDb pool (Insert.insert @ChapterTable @ChapterRow (ChapterCreate {id = Nothing, bookRef, heading}))+    >>= assertRight++insertSection :: DbPool -> UUID -> Text -> IO SectionRow+insertSection pool chapterRef label =+  runDb pool (Insert.insert @SectionTable @SectionRow (SectionCreate {id = Nothing, chapterRef, label}))+    >>= assertRight++insertTag :: DbPool -> UUID -> Text -> IO TagRow+insertTag pool shelfId label =+  runDb pool (Insert.insert @TagTable @TagRow (TagCreate {id = Nothing, shelfId, label}))+    >>= assertRight
+ test/Poppy/UniqueFailSpec.hs view
@@ -0,0 +1,42 @@+module Poppy.UniqueFailSpec+  ( uniqueFailSpec,+  )+where++import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import Test.Hspec++uniqueFailSpec :: Spec+uniqueFailSpec =+  describe "unique key type errors" $+    it "rejects a where_ passed to findUnique" $ do+      err <- expectFail "unique-fail/NonUniqueFilter.hs"+      err `shouldContain` "WidgetUniqueQuery"++expectFail :: FilePath -> IO String+expectFail path = do+  (code, _, err) <-+    readProcessWithExitCode+      "cabal"+      ( ["exec", "--", "ghc", "-package", "poppy", "-fno-code", "-w", "-itest", "-outputdir", "/tmp/poppy-unique-fail"]+          ++ extensions+          ++ [path]+      )+      ""+  case code of+    ExitSuccess -> expectationFailure ("expected " <> path <> " to fail") >> pure err+    _ -> pure err++extensions :: [String]+extensions =+  [ "-XAllowAmbiguousTypes",+    "-XDuplicateRecordFields",+    "-XLambdaCase",+    "-XNamedFieldPuns",+    "-XOverloadedRecordDot",+    "-XOverloadedStrings",+    "-XScopedTypeVariables",+    "-XTypeApplications",+    "-XTypeFamilies"+  ]
+ test/Poppy/WhereSpec.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.WhereSpec+  ( whereSpec,+  )+where++import Data.Text (Text)+import Poppy.Internal.Core (Field (..))+import Poppy.Internal.Where+  ( Where,+    and_,+    compileWhere,+    contains,+    eq,+    gt,+    in_,+    isNull,+    not_,+    or_,+  )+import Test.Hspec++data UserTable++userName :: Field UserTable Text+userName = Field "name" "name"++userAge :: Field UserTable Int+userAge = Field "age" "age"++whereSql :: Where UserTable -> Text+whereSql = fst . compileWhere++whereSpec :: Spec+whereSpec =+  describe "Poppy.Internal.Where" $ do+    it "compiles eq" $+      whereSql (eq userName "Ada") `shouldBe` "\"name\" = ?"++    it "compiles gt" $+      whereSql (gt userAge 30) `shouldBe` "\"age\" > ?"++    it "compiles isNull" $+      whereSql (isNull userName) `shouldBe` "\"name\" IS NULL"++    it "compiles empty in_ as FALSE" $+      whereSql (in_ userAge []) `shouldBe` "FALSE"++    it "compiles in_" $+      whereSql (in_ userAge [1, 2]) `shouldBe` "\"age\" IN ?"++    it "compiles contains as case-insensitive substring" $+      whereSql (contains userName "salt")+        `shouldBe` "POSITION(LOWER(?) IN LOWER(\"name\")) > 0"++    it "compiles and_ / or_ / not_ with parentheses" $+      whereSql (eq userName "Ada" `and_` not_ (isNull userAge) `or_` gt userAge 40)+        `shouldBe` "((\"name\" = ?) AND (NOT (\"age\" IS NULL))) OR (\"age\" > ?)"
+ test/Poppy/WidgetFixtures.hs view
@@ -0,0 +1,26 @@+module Poppy.WidgetFixtures+  ( insertWidget,+  )+where++import Data.Text (Text)+import Poppy (NullableValue (Omit), runDb)+import Poppy.Internal.Db (DbPool)+import qualified Poppy.Internal.Insert as Insert+import Schema.Widget+import Support.Assert (assertRight)++insertWidget :: DbPool -> Text -> IO WidgetRow+insertWidget pool name =+  runDb+    pool+    ( Insert.insert @WidgetTable @WidgetRow+        WidgetCreate+          { id = Nothing,+            createdAt = Nothing,+            updatedAt = Nothing,+            name,+            description = Omit+          }+    )+    >>= assertRight
+ test/Schema/Article.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Article+  ( ArticleTable (..),+    ArticleRow (..),+    ArticleSelect (..),+    ArticlePicked (..),+    articleSelect,+    articleSelectColumns,+    parseArticlePicked,+    toArticlePicked,+    ArticleCreate (..),+    ArticleUpdate (..),+    articleId,+    articleAuthorId,+    articleTitle+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data ArticleTable = ArticleTable++type instance PrimaryKeyType ArticleTable = UUID++type instance ModelTable "Article" = ArticleTable++instance Entity ArticleTable where+  tableName = "test_article"+  primaryKey = articleId+  tableColumns = ["id", "author_id", "title"]++instance Insertable ArticleTable where+  type CreateInput ArticleTable = ArticleCreate+  toInsertBuilder input =+    setMaybe articleId input.id $+      set articleAuthorId input.authorId $+      set articleTitle input.title $+      emptyInsert @ArticleTable+++instance Updatable ArticleTable where+  type UpdateInput ArticleTable = ArticleUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe articleAuthorId input.authorId $+      setFieldMaybe articleTitle input.title $+      emptyUpdate @ArticleTable+++data ArticleRow = ArticleRow+  { id :: UUID,+    authorId :: UUID,+    title :: Text+  }+  deriving (Show, Eq)+++data ArticleCreate = ArticleCreate+  { id :: Maybe UUID,+    authorId :: UUID,+    title :: Text+  }+  deriving (Show, Eq)+++data ArticleUpdate = ArticleUpdate+  { authorId :: Maybe UUID,+    title :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow ArticleRow where+  fromRow = ArticleRow <$> field <*> field <*> field+++data ArticleSelect = ArticleSelect+  { id :: Bool,+    authorId :: Bool,+    title :: Bool+  }+  deriving (Show, Eq)+data ArticlePicked = ArticlePicked+  { id :: UUID,+    authorId :: Picked UUID,+    title :: Picked Text+  }+  deriving (Show, Eq)+articleSelect :: ArticleSelect+articleSelect =+  ArticleSelect+    { id = False,+      authorId = False,+      title = False+    }+articleSelectColumns :: ArticleSelect -> [Text]+articleSelectColumns select_ =+  fieldColumn articleId+    : concat+      [ [fieldColumn articleAuthorId | select_.authorId]+      , [fieldColumn articleTitle | select_.title]+      ]+parseArticlePicked :: ArticleSelect -> RowParser ArticlePicked+parseArticlePicked select_ = do+  idVal <- field+  authorIdVal <- if select_.authorId then Picked <$> field else pure Skipped+  titleVal <- if select_.title then Picked <$> field else pure Skipped+  pure ArticlePicked { id = idVal, authorId = authorIdVal, title = titleVal }+toArticlePicked :: ArticleSelect -> ArticleRow -> ArticlePicked+toArticlePicked select_ row =+  ArticlePicked+    { id = row.id,+      authorId = picked select_.authorId row.authorId,+      title = picked select_.title row.title+    }+++articleId :: Field ArticleTable UUID+articleId = Field "id" "id"++articleAuthorId :: Field ArticleTable UUID+articleAuthorId = Field "authorId" "author_id"++articleTitle :: Field ArticleTable Text+articleTitle = Field "title" "title"+
+ test/Schema/Author.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Author+  ( AuthorTable (..),+    AuthorRow (..),+    AuthorSelect (..),+    AuthorPicked (..),+    authorSelect,+    authorSelectColumns,+    parseAuthorPicked,+    toAuthorPicked,+    AuthorCreate (..),+    AuthorUpdate (..),+    authorId,+    authorName+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data AuthorTable = AuthorTable++type instance PrimaryKeyType AuthorTable = UUID++type instance ModelTable "Author" = AuthorTable++instance Entity AuthorTable where+  tableName = "test_author"+  primaryKey = authorId+  tableColumns = ["id", "name"]++instance Insertable AuthorTable where+  type CreateInput AuthorTable = AuthorCreate+  toInsertBuilder input =+    setMaybe authorId input.id $+      set authorName input.name $+      emptyInsert @AuthorTable+++instance Updatable AuthorTable where+  type UpdateInput AuthorTable = AuthorUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe authorName input.name $+      emptyUpdate @AuthorTable+++data AuthorRow = AuthorRow+  { id :: UUID,+    name :: Text+  }+  deriving (Show, Eq)+++data AuthorCreate = AuthorCreate+  { id :: Maybe UUID,+    name :: Text+  }+  deriving (Show, Eq)+++data AuthorUpdate = AuthorUpdate+  { name :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow AuthorRow where+  fromRow = AuthorRow <$> field <*> field+++data AuthorSelect = AuthorSelect+  { id :: Bool,+    name :: Bool+  }+  deriving (Show, Eq)+data AuthorPicked = AuthorPicked+  { id :: UUID,+    name :: Picked Text+  }+  deriving (Show, Eq)+authorSelect :: AuthorSelect+authorSelect =+  AuthorSelect+    { id = False,+      name = False+    }+authorSelectColumns :: AuthorSelect -> [Text]+authorSelectColumns select_ =+  fieldColumn authorId+    : concat+      [ [fieldColumn authorName | select_.name]+      ]+parseAuthorPicked :: AuthorSelect -> RowParser AuthorPicked+parseAuthorPicked select_ = do+  idVal <- field+  nameVal <- if select_.name then Picked <$> field else pure Skipped+  pure AuthorPicked { id = idVal, name = nameVal }+toAuthorPicked :: AuthorSelect -> AuthorRow -> AuthorPicked+toAuthorPicked select_ row =+  AuthorPicked+    { id = row.id,+      name = picked select_.name row.name+    }+++authorId :: Field AuthorTable UUID+authorId = Field "id" "id"++authorName :: Field AuthorTable Text+authorName = Field "name" "name"+
+ test/Schema/Book.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Book+  ( BookTable (..),+    BookRow (..),+    BookSelect (..),+    BookPicked (..),+    bookSelect,+    bookSelectColumns,+    parseBookPicked,+    toBookPicked,+    BookCreate (..),+    BookUpdate (..),+    bookId,+    bookShelfId,+    bookTitle+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data BookTable = BookTable++type instance PrimaryKeyType BookTable = UUID++type instance ModelTable "Book" = BookTable++instance Entity BookTable where+  tableName = "test_book"+  primaryKey = bookId+  tableColumns = ["id", "shelf_id", "title"]++instance Insertable BookTable where+  type CreateInput BookTable = BookCreate+  toInsertBuilder input =+    setMaybe bookId input.id $+      set bookShelfId input.shelfId $+      set bookTitle input.title $+      emptyInsert @BookTable+++instance Updatable BookTable where+  type UpdateInput BookTable = BookUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe bookShelfId input.shelfId $+      setFieldMaybe bookTitle input.title $+      emptyUpdate @BookTable+++data BookRow = BookRow+  { id :: UUID,+    shelfId :: UUID,+    title :: Text+  }+  deriving (Show, Eq)+++data BookCreate = BookCreate+  { id :: Maybe UUID,+    shelfId :: UUID,+    title :: Text+  }+  deriving (Show, Eq)+++data BookUpdate = BookUpdate+  { shelfId :: Maybe UUID,+    title :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow BookRow where+  fromRow = BookRow <$> field <*> field <*> field+++data BookSelect = BookSelect+  { id :: Bool,+    shelfId :: Bool,+    title :: Bool+  }+  deriving (Show, Eq)+data BookPicked = BookPicked+  { id :: UUID,+    shelfId :: Picked UUID,+    title :: Picked Text+  }+  deriving (Show, Eq)+bookSelect :: BookSelect+bookSelect =+  BookSelect+    { id = False,+      shelfId = False,+      title = False+    }+bookSelectColumns :: BookSelect -> [Text]+bookSelectColumns select_ =+  fieldColumn bookId+    : concat+      [ [fieldColumn bookShelfId | select_.shelfId]+      , [fieldColumn bookTitle | select_.title]+      ]+parseBookPicked :: BookSelect -> RowParser BookPicked+parseBookPicked select_ = do+  idVal <- field+  shelfIdVal <- if select_.shelfId then Picked <$> field else pure Skipped+  titleVal <- if select_.title then Picked <$> field else pure Skipped+  pure BookPicked { id = idVal, shelfId = shelfIdVal, title = titleVal }+toBookPicked :: BookSelect -> BookRow -> BookPicked+toBookPicked select_ row =+  BookPicked+    { id = row.id,+      shelfId = picked select_.shelfId row.shelfId,+      title = picked select_.title row.title+    }+++bookId :: Field BookTable UUID+bookId = Field "id" "id"++bookShelfId :: Field BookTable UUID+bookShelfId = Field "shelfId" "shelf_id"++bookTitle :: Field BookTable Text+bookTitle = Field "title" "title"+
+ test/Schema/Chapter.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Chapter+  ( ChapterTable (..),+    ChapterRow (..),+    ChapterSelect (..),+    ChapterPicked (..),+    chapterSelect,+    chapterSelectColumns,+    parseChapterPicked,+    toChapterPicked,+    ChapterCreate (..),+    ChapterUpdate (..),+    chapterId,+    chapterBookRef,+    chapterHeading+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data ChapterTable = ChapterTable++type instance PrimaryKeyType ChapterTable = UUID++type instance ModelTable "Chapter" = ChapterTable++instance Entity ChapterTable where+  tableName = "test_chapter"+  primaryKey = chapterId+  tableColumns = ["id", "book_id", "heading"]++instance Insertable ChapterTable where+  type CreateInput ChapterTable = ChapterCreate+  toInsertBuilder input =+    setMaybe chapterId input.id $+      set chapterBookRef input.bookRef $+      set chapterHeading input.heading $+      emptyInsert @ChapterTable+++instance Updatable ChapterTable where+  type UpdateInput ChapterTable = ChapterUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe chapterBookRef input.bookRef $+      setFieldMaybe chapterHeading input.heading $+      emptyUpdate @ChapterTable+++data ChapterRow = ChapterRow+  { id :: UUID,+    bookRef :: UUID,+    heading :: Text+  }+  deriving (Show, Eq)+++data ChapterCreate = ChapterCreate+  { id :: Maybe UUID,+    bookRef :: UUID,+    heading :: Text+  }+  deriving (Show, Eq)+++data ChapterUpdate = ChapterUpdate+  { bookRef :: Maybe UUID,+    heading :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow ChapterRow where+  fromRow = ChapterRow <$> field <*> field <*> field+++data ChapterSelect = ChapterSelect+  { id :: Bool,+    bookRef :: Bool,+    heading :: Bool+  }+  deriving (Show, Eq)+data ChapterPicked = ChapterPicked+  { id :: UUID,+    bookRef :: Picked UUID,+    heading :: Picked Text+  }+  deriving (Show, Eq)+chapterSelect :: ChapterSelect+chapterSelect =+  ChapterSelect+    { id = False,+      bookRef = False,+      heading = False+    }+chapterSelectColumns :: ChapterSelect -> [Text]+chapterSelectColumns select_ =+  fieldColumn chapterId+    : concat+      [ [fieldColumn chapterBookRef | select_.bookRef]+      , [fieldColumn chapterHeading | select_.heading]+      ]+parseChapterPicked :: ChapterSelect -> RowParser ChapterPicked+parseChapterPicked select_ = do+  idVal <- field+  bookRefVal <- if select_.bookRef then Picked <$> field else pure Skipped+  headingVal <- if select_.heading then Picked <$> field else pure Skipped+  pure ChapterPicked { id = idVal, bookRef = bookRefVal, heading = headingVal }+toChapterPicked :: ChapterSelect -> ChapterRow -> ChapterPicked+toChapterPicked select_ row =+  ChapterPicked+    { id = row.id,+      bookRef = picked select_.bookRef row.bookRef,+      heading = picked select_.heading row.heading+    }+++chapterId :: Field ChapterTable UUID+chapterId = Field "id" "id"++chapterBookRef :: Field ChapterTable UUID+chapterBookRef = Field "bookRef" "book_id"++chapterHeading :: Field ChapterTable Text+chapterHeading = Field "heading" "heading"+
+ test/Schema/Client/Article.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Schema.Client.Article+  ( create,+    createMany,+    update,+    updateMany,+    upsert,+    findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    delete,+    deleteMany,+    ArticleCreate (..),+    ArticleRow (..),+    ArticleSelect (..),+    ArticlePicked (..),+    articleSelect,+    OmitSelect (..),+    Picked (..),+    ResolveSelect,+    ArticleUpdate (..),+    ArticleTable,+    ArticleQuery (..),+    ArticleUnique (..),+    ArticleUniqueKey (..),+    ArticleUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    articleUniqueWhere,+    articleId+  )++where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    QueryBuilder,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    Where,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Article (ArticleCreate (..), ArticleRow (..), ArticleSelect (..), ArticlePicked (..), articleSelect, articleSelectColumns, parseArticlePicked, ArticleTable, ArticleUpdate (..), articleId)++data ArticleUnique+  = ById UUID+  deriving (Eq, Show)++data ArticleUniqueKey+  = OnId+  deriving (Eq, Show)++articleUniqueWhere :: ArticleUnique -> Where ArticleTable+articleUniqueWhere = \case+  ById v1 -> eq articleId v1++articleConflictCols :: ArticleUniqueKey -> [Text]+articleConflictCols = \case+  OnId -> ["id"]+++create :: ArticleCreate -> Db (Either ORMError ArticleRow)+create = Insert.insert @ArticleTable @ArticleRow+++createMany :: [ArticleCreate] -> Db (Either ORMError Int)+createMany = Insert.insertMany @ArticleTable+++update :: ArticleUnique -> ArticleUpdate -> Db (Either ORMError ArticleRow)+update key input =+  Update.updateWhere @ArticleTable @ArticleRow (articleUniqueWhere key) input+++updateMany :: Where ArticleTable -> ArticleUpdate -> Db (Either ORMError Int)+updateMany = Update.updateMany @ArticleTable+++upsert :: ArticleUniqueKey -> ArticleCreate -> ArticleUpdate -> Db (Either ORMError ArticleRow)+upsert key createInput updateInput =+  Insert.upsert @ArticleTable @ArticleRow (articleConflictCols key) createInput updateInput+++data ArticleQuery select = ArticleQuery+  { select_ :: select+  , where_ :: Maybe (Where ArticleTable)+  , orderBy_ :: [OrderBy ArticleTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }+++data ArticleUniqueQuery select = ArticleUniqueQuery+  { select_ :: select+  , where_ :: ArticleUnique+  }+++emptyQuery :: ArticleQuery OmitSelect+emptyQuery =+  ArticleQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}+++uniqueQuery :: ArticleUnique -> ArticleUniqueQuery OmitSelect+uniqueQuery key =+  ArticleUniqueQuery {select_ = OmitSelect, where_ = key}+++type family ResolveSelect select+type instance ResolveSelect OmitSelect = ArticleRow+type instance ResolveSelect ArticleSelect = ArticlePicked+++class ReadArticle select where+  findMany :: ArticleQuery select -> Db [ResolveSelect select]+  findUnique :: ArticleUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select)))+  findUniqueOrFail :: ArticleUniqueQuery select -> Db (Either ORMError (ResolveSelect select))+  findFirst :: ArticleQuery select -> Db (Maybe (ResolveSelect select))+  findFirstOrFail :: ArticleQuery select -> Db (Either ORMError (ResolveSelect select))++instance ReadArticle OmitSelect where+  findMany q =+    Ops.findMany @ArticleTable @ArticleRow (applyQuery q)+  findUnique ArticleUniqueQuery {where_} = do+    let w = articleUniqueWhere where_+    rows <- Ops.findMany @ArticleTable @ArticleRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q =+    Ops.findFirst @ArticleTable @ArticleRow (applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadArticle ArticleSelect where+  findMany q@ArticleQuery {select_} =+    Ops.findManyWith+      (parseArticlePicked select_)+      (selectColumns (articleSelectColumns select_) . applyQuery q)+  findUnique ArticleUniqueQuery {where_, select_} = do+    let w = articleUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseArticlePicked select_)+        (selectColumns (articleSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q@ArticleQuery {select_} =+    Ops.findFirstWith+      (parseArticlePicked select_)+      (selectColumns (articleSelectColumns select_) . applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++applyQuery :: ArticleQuery select -> QueryBuilder ArticleTable -> QueryBuilder ArticleTable+applyQuery ArticleQuery {where_, orderBy_, limit_, offset_} =+  applyQueryModifiers where_ orderBy_ limit_ offset_+++count :: ArticleQuery select -> Db Int+count q = Ops.count @ArticleTable (applyQuery q)+++delete :: ArticleUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @ArticleTable (articleUniqueWhere key)+++deleteMany :: Where ArticleTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @ArticleTable+
+ test/Schema/Client/Author.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.++Nested writes live on 'create' / 'update'.+  create-time relation fields are [CreateChild | ConnectChild unique]+  update-time relation fields are Maybe <Rel>Update (replaceWith, create, connect, delete, update, upsert;+  disconnect when the child foreign key is nullable)+-}+module Schema.Client.Author+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    AuthorCreateScalars,+    AuthorUpdateScalars,+    PostNestedCreate (..),+    PostNestedUpsert (..),+    PostsUpdate (..),+    emptyPostsUpdate,+    AuthorQuery (..),+    AuthorUnique (..),+    AuthorUniqueKey (..),+    AuthorUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    authorUniqueWhere,+    OmitSelect (..),+    Picked (..),+    AuthorCreate (..),+    AuthorRow (..),+    AuthorSelect (..),+    AuthorPicked (..),+    authorSelect,+    AuthorUpdate (..),+    AuthorTable,+    authorId+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    transactionEither,+    fieldColumn,+    toField,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    and_,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Author (AuthorRow (..), AuthorSelect (..), AuthorPicked (..), authorSelect, authorSelectColumns, parseAuthorPicked, AuthorTable, authorId)+import qualified Schema.Author as AuthorSchema (AuthorCreate (..), AuthorUpdate (..))++import Schema.Include.Author (LoadAuthor (..), AuthorInclude (..), AuthorRead, toAuthorWithPicked)+import Schema.Post (PostRow (..), PostTable, postId, postAuthorId, PostCreate (..), PostUpdate (..))+import qualified Schema.Client.Post as Post (PostUnique (..), postUniqueWhere)+import Schema.PostStatus (PostStatus (..))++data AuthorUnique+  = ById UUID+  deriving (Eq, Show)++data AuthorUniqueKey+  = OnId+  deriving (Eq, Show)++authorUniqueWhere :: AuthorUnique -> Where AuthorTable+authorUniqueWhere = \case+  ById v1 -> eq authorId v1++authorConflictCols :: AuthorUniqueKey -> [Text]+authorConflictCols = \case+  OnId -> ["id"]++data PostNestedCreate+  = CreatePost+      { id :: Maybe UUID, title :: Text, status :: PostStatus+      }+  | ConnectPost Post.PostUnique+  deriving (Show, Eq)+data PostNestedUpsert = PostNestedUpsert+  { where_ :: Post.PostUnique+  , create :: PostNestedCreate+  , update :: PostUpdate+  }+  deriving (Show, Eq)+data PostsUpdate = PostsUpdate+  { replaceWith :: Maybe [PostNestedCreate]+  , create :: [PostNestedCreate]+  , createMany :: [PostNestedCreate]+  , connect :: [Post.PostUnique]+  , delete :: [Post.PostUnique]+  , update :: [(Post.PostUnique, PostUpdate)]+  , upsert :: [PostNestedUpsert]+  }+  deriving (Show, Eq)++emptyPostsUpdate :: PostsUpdate+emptyPostsUpdate =+  PostsUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data AuthorCreate = AuthorCreate+  { id :: Maybe UUID,+    name :: Text,+    posts :: [PostNestedCreate]+  }+  deriving (Show, Eq)++type AuthorCreateScalars = AuthorSchema.AuthorCreate++toAuthorCreateScalars :: AuthorCreate -> AuthorCreateScalars+toAuthorCreateScalars input =+  AuthorSchema.AuthorCreate+    { id = input.id,+      name = input.name+    }+data AuthorUpdate = AuthorUpdate+  { name :: Maybe Text,+    posts :: Maybe PostsUpdate+  }+  deriving (Show, Eq)++type AuthorUpdateScalars = AuthorSchema.AuthorUpdate++toAuthorUpdateScalars :: AuthorUpdate -> AuthorUpdateScalars+toAuthorUpdateScalars input =+  AuthorSchema.AuthorUpdate+    { name = input.name+    }++create :: AuthorCreate -> Db (Either ORMError AuthorRow)+create input =+  if hasAuthorNestedCreate input+    then transactionEither (createWithNested input)+    else Insert.insert @AuthorTable @AuthorRow (toAuthorCreateScalars input)++hasAuthorNestedCreate :: AuthorCreate -> Bool+hasAuthorNestedCreate input =+  not (null input.posts)++createWithNested :: AuthorCreate -> Db (Either ORMError AuthorRow)+createWithNested input = do+  rootResult <- Insert.insert @AuthorTable @AuthorRow (toAuthorCreateScalars input)+  case rootResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ applyPostsCreate row.id input.posts+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++createMany :: [AuthorCreateScalars] -> Db (Either ORMError Int)+createMany = Insert.insertMany @AuthorTable++update :: AuthorUnique -> AuthorUpdate -> Db (Either ORMError AuthorRow)+update key input =+  if hasAuthorNestedUpdate input+    then transactionEither (updateWithNested key input)+    else Update.updateWhere @AuthorTable @AuthorRow (authorUniqueWhere key) (toAuthorUpdateScalars input)++hasAuthorNestedUpdate :: AuthorUpdate -> Bool+hasAuthorNestedUpdate input =+  isJust input.posts++updateWithNested :: AuthorUnique -> AuthorUpdate -> Db (Either ORMError AuthorRow)+updateWithNested key input = do+  updateResult <- Update.updateWhere @AuthorTable @AuthorRow (authorUniqueWhere key) (toAuthorUpdateScalars input)+  case updateResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ maybe (pure (Right ())) (applyPostsUpdate row.id) input.posts+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++updateMany :: Where AuthorTable -> AuthorUpdateScalars -> Db (Either ORMError Int)+updateMany = Update.updateMany @AuthorTable++upsert :: AuthorUniqueKey -> AuthorCreateScalars -> AuthorUpdateScalars -> Db (Either ORMError AuthorRow)+upsert key createInput updateInput =+  Insert.upsert @AuthorTable @AuthorRow (authorConflictCols key) createInput updateInput++sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ())+sequenceNested [] = pure (Right ())+sequenceNested (action : rest) = do+  result <- action+  case result of+    Left err -> pure (Left err)+    Right () -> sequenceNested rest+applyPostsCreate :: UUID -> [PostNestedCreate] -> Db (Either ORMError ())+applyPostsCreate = insertPosts+applyPostsUpdate :: UUID -> PostsUpdate -> Db (Either ORMError ())+applyPostsUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replacePosts parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deletePosts parentId ops.delete+        , updatePostsRows parentId ops.update+        , upsertPosts parentId ops.upsert+        , insertPosts parentId ops.create+        , insertPosts parentId ops.createMany+        , connectPosts parentId ops.connect+        ]+replacePosts :: UUID -> [PostNestedCreate] -> Db (Either ORMError ())+replacePosts parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn postAuthorId <> " = ?") [toField parentId] (Delete.emptyDelete @PostTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertPosts parentId items+insertPosts :: UUID -> [PostNestedCreate] -> Db (Either ORMError ())+insertPosts parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectPost key -> connectPosts parentId [key]+        CreatePost {id, title, status} -> do+          inserted <- Insert.insert @PostTable @PostRow PostCreate+            { id = id,+              title = title,+              status = status,+              authorId = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deletePosts :: UUID -> [Post.PostUnique] -> Db (Either ORMError ())+deletePosts _ [] = pure (Right ())+deletePosts parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @PostTable+        (Post.postUniqueWhere key `and_` eq postAuthorId parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updatePostsRows :: UUID -> [(Post.PostUnique, PostUpdate)] -> Db (Either ORMError ())+updatePostsRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = PostUpdate { authorId = Nothing, title = nested.title, status = nested.status }+      result <-+        Update.updateWhere @PostTable @PostRow+          (Post.postUniqueWhere key `and_` eq postAuthorId parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertPosts :: UUID -> [PostNestedUpsert] -> Db (Either ORMError ())+upsertPosts parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @PostTable @PostRow (matching (Post.postUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertPosts parentId [item.create]+        Right (Just row) ->+          if row.authorId == parentId+            then do+              let patched = PostUpdate { authorId = Nothing, title = item.update.title, status = item.update.status }+              updated <-+                Update.updateWhere @PostTable @PostRow+                  (Post.postUniqueWhere item.where_ `and_` eq postAuthorId parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectPosts :: UUID -> [Post.PostUnique] -> Db (Either ORMError ())+connectPosts _ [] = pure (Right ())+connectPosts parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @PostTable @PostRow+          (Post.postUniqueWhere key)+          (PostUpdate+            { authorId = Just parentId,+              title = Nothing,+              status = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()++data AuthorQuery include select = AuthorQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where AuthorTable)+  , orderBy_ :: [OrderBy AuthorTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data AuthorUniqueQuery include select = AuthorUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: AuthorUnique+  }++emptyQuery :: AuthorQuery () OmitSelect+emptyQuery =+  AuthorQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: AuthorUnique -> AuthorUniqueQuery () OmitSelect+uniqueQuery key =+  AuthorUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadAuthor include select where+  findMany :: AuthorQuery include select -> Db [AuthorRead include select]+  findUnique :: AuthorUniqueQuery include select -> Db (Either ORMError (Maybe (AuthorRead include select)))+  findUniqueOrFail :: AuthorUniqueQuery include select -> Db (Either ORMError (AuthorRead include select))+  findFirst :: AuthorQuery include select -> Db (Maybe (AuthorRead include select))+  findFirstOrFail :: AuthorQuery include select -> Db (Either ORMError (AuthorRead include select))++instance (LoadAuthor posts) => ReadAuthor (AuthorInclude posts) OmitSelect where+  findMany AuthorQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadAuthor include_ roots+  findUnique AuthorUniqueQuery {where_, include_} = do+    let w = authorUniqueWhere where_+    roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (matching w))+    rows <- loadAuthor include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst AuthorQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadAuthor include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadAuthor () OmitSelect where+  findMany AuthorQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @AuthorTable @AuthorRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique AuthorUniqueQuery {where_} = do+    let w = authorUniqueWhere where_+    rows <- Ops.findMany @AuthorTable @AuthorRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst AuthorQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @AuthorTable @AuthorRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadAuthor posts) => ReadAuthor (AuthorInclude posts) AuthorSelect where+  findMany AuthorQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadAuthor include_ roots+    pure $ map (toAuthorWithPicked select_) loaded+  findUnique AuthorUniqueQuery {where_, include_, select_} = do+    let w = authorUniqueWhere where_+    roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (matching w))+    loaded <- loadAuthor include_ roots+    let rows = map (toAuthorWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst AuthorQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadAuthor include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toAuthorWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadAuthor () AuthorSelect where+  findMany AuthorQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parseAuthorPicked select_)+      (selectColumns (authorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique AuthorUniqueQuery {where_, select_} = do+    let w = authorUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseAuthorPicked select_)+        (selectColumns (authorSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst AuthorQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parseAuthorPicked select_)+      (selectColumns (authorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: AuthorQuery include select -> Db Int+count AuthorQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @AuthorTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: AuthorUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @AuthorTable (authorUniqueWhere key)++deleteMany :: Where AuthorTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @AuthorTable
+ test/Schema/Client/Book.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.++Nested writes live on 'create' / 'update'.+  create-time relation fields are [CreateChild | ConnectChild unique]+  update-time relation fields are Maybe <Rel>Update (replaceWith, create, connect, delete, update, upsert;+  disconnect when the child foreign key is nullable)+-}+module Schema.Client.Book+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    BookCreateScalars,+    BookUpdateScalars,+    ChapterNestedCreate (..),+    ChapterNestedUpsert (..),+    ChaptersUpdate (..),+    emptyChaptersUpdate,+    BookQuery (..),+    BookUnique (..),+    BookUniqueKey (..),+    BookUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    bookUniqueWhere,+    OmitSelect (..),+    Picked (..),+    BookCreate (..),+    BookRow (..),+    BookSelect (..),+    BookPicked (..),+    bookSelect,+    BookUpdate (..),+    BookTable,+    bookId+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    transactionEither,+    fieldColumn,+    toField,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    and_,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Book (BookRow (..), BookSelect (..), BookPicked (..), bookSelect, bookSelectColumns, parseBookPicked, BookTable, bookId)+import qualified Schema.Book as BookSchema (BookCreate (..), BookUpdate (..))++import Schema.Include.Book (LoadBook (..), BookInclude (..), BookRead, toBookWithPicked)+import Schema.Chapter (ChapterRow (..), ChapterTable, chapterId, chapterBookRef, ChapterCreate (..), ChapterUpdate (..))+import qualified Schema.Client.Chapter as Chapter (ChapterUnique (..), chapterUniqueWhere)++data BookUnique+  = ById UUID+  deriving (Eq, Show)++data BookUniqueKey+  = OnId+  deriving (Eq, Show)++bookUniqueWhere :: BookUnique -> Where BookTable+bookUniqueWhere = \case+  ById v1 -> eq bookId v1++bookConflictCols :: BookUniqueKey -> [Text]+bookConflictCols = \case+  OnId -> ["id"]++data ChapterNestedCreate+  = CreateChapter+      { id :: Maybe UUID, heading :: Text+      }+  | ConnectChapter Chapter.ChapterUnique+  deriving (Show, Eq)+data ChapterNestedUpsert = ChapterNestedUpsert+  { where_ :: Chapter.ChapterUnique+  , create :: ChapterNestedCreate+  , update :: ChapterUpdate+  }+  deriving (Show, Eq)+data ChaptersUpdate = ChaptersUpdate+  { replaceWith :: Maybe [ChapterNestedCreate]+  , create :: [ChapterNestedCreate]+  , createMany :: [ChapterNestedCreate]+  , connect :: [Chapter.ChapterUnique]+  , delete :: [Chapter.ChapterUnique]+  , update :: [(Chapter.ChapterUnique, ChapterUpdate)]+  , upsert :: [ChapterNestedUpsert]+  }+  deriving (Show, Eq)++emptyChaptersUpdate :: ChaptersUpdate+emptyChaptersUpdate =+  ChaptersUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data BookCreate = BookCreate+  { id :: Maybe UUID,+    shelfId :: UUID,+    title :: Text,+    chapters :: [ChapterNestedCreate]+  }+  deriving (Show, Eq)++type BookCreateScalars = BookSchema.BookCreate++toBookCreateScalars :: BookCreate -> BookCreateScalars+toBookCreateScalars input =+  BookSchema.BookCreate+    { id = input.id,+      shelfId = input.shelfId,+      title = input.title+    }+data BookUpdate = BookUpdate+  { shelfId :: Maybe UUID,+    title :: Maybe Text,+    chapters :: Maybe ChaptersUpdate+  }+  deriving (Show, Eq)++type BookUpdateScalars = BookSchema.BookUpdate++toBookUpdateScalars :: BookUpdate -> BookUpdateScalars+toBookUpdateScalars input =+  BookSchema.BookUpdate+    { shelfId = input.shelfId,+      title = input.title+    }++create :: BookCreate -> Db (Either ORMError BookRow)+create input =+  if hasBookNestedCreate input+    then transactionEither (createWithNested input)+    else Insert.insert @BookTable @BookRow (toBookCreateScalars input)++hasBookNestedCreate :: BookCreate -> Bool+hasBookNestedCreate input =+  not (null input.chapters)++createWithNested :: BookCreate -> Db (Either ORMError BookRow)+createWithNested input = do+  rootResult <- Insert.insert @BookTable @BookRow (toBookCreateScalars input)+  case rootResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ applyChaptersCreate row.id input.chapters+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++createMany :: [BookCreateScalars] -> Db (Either ORMError Int)+createMany = Insert.insertMany @BookTable++update :: BookUnique -> BookUpdate -> Db (Either ORMError BookRow)+update key input =+  if hasBookNestedUpdate input+    then transactionEither (updateWithNested key input)+    else Update.updateWhere @BookTable @BookRow (bookUniqueWhere key) (toBookUpdateScalars input)++hasBookNestedUpdate :: BookUpdate -> Bool+hasBookNestedUpdate input =+  isJust input.chapters++updateWithNested :: BookUnique -> BookUpdate -> Db (Either ORMError BookRow)+updateWithNested key input = do+  updateResult <- Update.updateWhere @BookTable @BookRow (bookUniqueWhere key) (toBookUpdateScalars input)+  case updateResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ maybe (pure (Right ())) (applyChaptersUpdate row.id) input.chapters+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++updateMany :: Where BookTable -> BookUpdateScalars -> Db (Either ORMError Int)+updateMany = Update.updateMany @BookTable++upsert :: BookUniqueKey -> BookCreateScalars -> BookUpdateScalars -> Db (Either ORMError BookRow)+upsert key createInput updateInput =+  Insert.upsert @BookTable @BookRow (bookConflictCols key) createInput updateInput++sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ())+sequenceNested [] = pure (Right ())+sequenceNested (action : rest) = do+  result <- action+  case result of+    Left err -> pure (Left err)+    Right () -> sequenceNested rest+applyChaptersCreate :: UUID -> [ChapterNestedCreate] -> Db (Either ORMError ())+applyChaptersCreate = insertChapters+applyChaptersUpdate :: UUID -> ChaptersUpdate -> Db (Either ORMError ())+applyChaptersUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceChapters parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteChapters parentId ops.delete+        , updateChaptersRows parentId ops.update+        , upsertChapters parentId ops.upsert+        , insertChapters parentId ops.create+        , insertChapters parentId ops.createMany+        , connectChapters parentId ops.connect+        ]+replaceChapters :: UUID -> [ChapterNestedCreate] -> Db (Either ORMError ())+replaceChapters parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn chapterBookRef <> " = ?") [toField parentId] (Delete.emptyDelete @ChapterTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertChapters parentId items+insertChapters :: UUID -> [ChapterNestedCreate] -> Db (Either ORMError ())+insertChapters parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectChapter key -> connectChapters parentId [key]+        CreateChapter {id, heading} -> do+          inserted <- Insert.insert @ChapterTable @ChapterRow ChapterCreate+            { id = id,+              heading = heading,+              bookRef = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteChapters :: UUID -> [Chapter.ChapterUnique] -> Db (Either ORMError ())+deleteChapters _ [] = pure (Right ())+deleteChapters parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @ChapterTable+        (Chapter.chapterUniqueWhere key `and_` eq chapterBookRef parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateChaptersRows :: UUID -> [(Chapter.ChapterUnique, ChapterUpdate)] -> Db (Either ORMError ())+updateChaptersRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = ChapterUpdate { bookRef = Nothing, heading = nested.heading }+      result <-+        Update.updateWhere @ChapterTable @ChapterRow+          (Chapter.chapterUniqueWhere key `and_` eq chapterBookRef parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertChapters :: UUID -> [ChapterNestedUpsert] -> Db (Either ORMError ())+upsertChapters parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @ChapterTable @ChapterRow (matching (Chapter.chapterUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertChapters parentId [item.create]+        Right (Just row) ->+          if row.bookRef == parentId+            then do+              let patched = ChapterUpdate { bookRef = Nothing, heading = item.update.heading }+              updated <-+                Update.updateWhere @ChapterTable @ChapterRow+                  (Chapter.chapterUniqueWhere item.where_ `and_` eq chapterBookRef parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectChapters :: UUID -> [Chapter.ChapterUnique] -> Db (Either ORMError ())+connectChapters _ [] = pure (Right ())+connectChapters parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @ChapterTable @ChapterRow+          (Chapter.chapterUniqueWhere key)+          (ChapterUpdate+            { bookRef = Just parentId,+              heading = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()++data BookQuery include select = BookQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where BookTable)+  , orderBy_ :: [OrderBy BookTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data BookUniqueQuery include select = BookUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: BookUnique+  }++emptyQuery :: BookQuery () OmitSelect+emptyQuery =+  BookQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: BookUnique -> BookUniqueQuery () OmitSelect+uniqueQuery key =+  BookUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadBook include select where+  findMany :: BookQuery include select -> Db [BookRead include select]+  findUnique :: BookUniqueQuery include select -> Db (Either ORMError (Maybe (BookRead include select)))+  findUniqueOrFail :: BookUniqueQuery include select -> Db (Either ORMError (BookRead include select))+  findFirst :: BookQuery include select -> Db (Maybe (BookRead include select))+  findFirstOrFail :: BookQuery include select -> Db (Either ORMError (BookRead include select))++instance (LoadBook chapters) => ReadBook (BookInclude chapters) OmitSelect where+  findMany BookQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadBook include_ roots+  findUnique BookUniqueQuery {where_, include_} = do+    let w = bookUniqueWhere where_+    roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (matching w))+    rows <- loadBook include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst BookQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadBook include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadBook () OmitSelect where+  findMany BookQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @BookTable @BookRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique BookUniqueQuery {where_} = do+    let w = bookUniqueWhere where_+    rows <- Ops.findMany @BookTable @BookRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst BookQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @BookTable @BookRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadBook chapters) => ReadBook (BookInclude chapters) BookSelect where+  findMany BookQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadBook include_ roots+    pure $ map (toBookWithPicked select_) loaded+  findUnique BookUniqueQuery {where_, include_, select_} = do+    let w = bookUniqueWhere where_+    roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (matching w))+    loaded <- loadBook include_ roots+    let rows = map (toBookWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst BookQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadBook include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toBookWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadBook () BookSelect where+  findMany BookQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parseBookPicked select_)+      (selectColumns (bookSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique BookUniqueQuery {where_, select_} = do+    let w = bookUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseBookPicked select_)+        (selectColumns (bookSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst BookQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parseBookPicked select_)+      (selectColumns (bookSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: BookQuery include select -> Db Int+count BookQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @BookTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: BookUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @BookTable (bookUniqueWhere key)++deleteMany :: Where BookTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @BookTable
+ test/Schema/Client/Chapter.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.++Nested writes live on 'create' / 'update'.+  create-time relation fields are [CreateChild | ConnectChild unique]+  update-time relation fields are Maybe <Rel>Update (replaceWith, create, connect, delete, update, upsert;+  disconnect when the child foreign key is nullable)+-}+module Schema.Client.Chapter+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    ChapterCreateScalars,+    ChapterUpdateScalars,+    SectionNestedCreate (..),+    SectionNestedUpsert (..),+    SectionsUpdate (..),+    emptySectionsUpdate,+    ChapterQuery (..),+    ChapterUnique (..),+    ChapterUniqueKey (..),+    ChapterUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    chapterUniqueWhere,+    OmitSelect (..),+    Picked (..),+    ChapterCreate (..),+    ChapterRow (..),+    ChapterSelect (..),+    ChapterPicked (..),+    chapterSelect,+    ChapterUpdate (..),+    ChapterTable,+    chapterId+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    transactionEither,+    fieldColumn,+    toField,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    and_,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Chapter (ChapterRow (..), ChapterSelect (..), ChapterPicked (..), chapterSelect, chapterSelectColumns, parseChapterPicked, ChapterTable, chapterId)+import qualified Schema.Chapter as ChapterSchema (ChapterCreate (..), ChapterUpdate (..))++import Schema.Include.Chapter (LoadChapter (..), ChapterInclude (..), ChapterRead, toChapterWithPicked)+import Schema.Section (SectionRow (..), SectionTable, sectionId, sectionChapterRef, SectionCreate (..), SectionUpdate (..))+import qualified Schema.Client.Section as Section (SectionUnique (..), sectionUniqueWhere)++data ChapterUnique+  = ById UUID+  deriving (Eq, Show)++data ChapterUniqueKey+  = OnId+  deriving (Eq, Show)++chapterUniqueWhere :: ChapterUnique -> Where ChapterTable+chapterUniqueWhere = \case+  ById v1 -> eq chapterId v1++chapterConflictCols :: ChapterUniqueKey -> [Text]+chapterConflictCols = \case+  OnId -> ["id"]++data SectionNestedCreate+  = CreateSection+      { id :: Maybe UUID, label :: Text+      }+  | ConnectSection Section.SectionUnique+  deriving (Show, Eq)+data SectionNestedUpsert = SectionNestedUpsert+  { where_ :: Section.SectionUnique+  , create :: SectionNestedCreate+  , update :: SectionUpdate+  }+  deriving (Show, Eq)+data SectionsUpdate = SectionsUpdate+  { replaceWith :: Maybe [SectionNestedCreate]+  , create :: [SectionNestedCreate]+  , createMany :: [SectionNestedCreate]+  , connect :: [Section.SectionUnique]+  , delete :: [Section.SectionUnique]+  , update :: [(Section.SectionUnique, SectionUpdate)]+  , upsert :: [SectionNestedUpsert]+  }+  deriving (Show, Eq)++emptySectionsUpdate :: SectionsUpdate+emptySectionsUpdate =+  SectionsUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data ChapterCreate = ChapterCreate+  { id :: Maybe UUID,+    bookRef :: UUID,+    heading :: Text,+    sections :: [SectionNestedCreate]+  }+  deriving (Show, Eq)++type ChapterCreateScalars = ChapterSchema.ChapterCreate++toChapterCreateScalars :: ChapterCreate -> ChapterCreateScalars+toChapterCreateScalars input =+  ChapterSchema.ChapterCreate+    { id = input.id,+      bookRef = input.bookRef,+      heading = input.heading+    }+data ChapterUpdate = ChapterUpdate+  { bookRef :: Maybe UUID,+    heading :: Maybe Text,+    sections :: Maybe SectionsUpdate+  }+  deriving (Show, Eq)++type ChapterUpdateScalars = ChapterSchema.ChapterUpdate++toChapterUpdateScalars :: ChapterUpdate -> ChapterUpdateScalars+toChapterUpdateScalars input =+  ChapterSchema.ChapterUpdate+    { bookRef = input.bookRef,+      heading = input.heading+    }++create :: ChapterCreate -> Db (Either ORMError ChapterRow)+create input =+  if hasChapterNestedCreate input+    then transactionEither (createWithNested input)+    else Insert.insert @ChapterTable @ChapterRow (toChapterCreateScalars input)++hasChapterNestedCreate :: ChapterCreate -> Bool+hasChapterNestedCreate input =+  not (null input.sections)++createWithNested :: ChapterCreate -> Db (Either ORMError ChapterRow)+createWithNested input = do+  rootResult <- Insert.insert @ChapterTable @ChapterRow (toChapterCreateScalars input)+  case rootResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ applySectionsCreate row.id input.sections+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++createMany :: [ChapterCreateScalars] -> Db (Either ORMError Int)+createMany = Insert.insertMany @ChapterTable++update :: ChapterUnique -> ChapterUpdate -> Db (Either ORMError ChapterRow)+update key input =+  if hasChapterNestedUpdate input+    then transactionEither (updateWithNested key input)+    else Update.updateWhere @ChapterTable @ChapterRow (chapterUniqueWhere key) (toChapterUpdateScalars input)++hasChapterNestedUpdate :: ChapterUpdate -> Bool+hasChapterNestedUpdate input =+  isJust input.sections++updateWithNested :: ChapterUnique -> ChapterUpdate -> Db (Either ORMError ChapterRow)+updateWithNested key input = do+  updateResult <- Update.updateWhere @ChapterTable @ChapterRow (chapterUniqueWhere key) (toChapterUpdateScalars input)+  case updateResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ maybe (pure (Right ())) (applySectionsUpdate row.id) input.sections+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++updateMany :: Where ChapterTable -> ChapterUpdateScalars -> Db (Either ORMError Int)+updateMany = Update.updateMany @ChapterTable++upsert :: ChapterUniqueKey -> ChapterCreateScalars -> ChapterUpdateScalars -> Db (Either ORMError ChapterRow)+upsert key createInput updateInput =+  Insert.upsert @ChapterTable @ChapterRow (chapterConflictCols key) createInput updateInput++sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ())+sequenceNested [] = pure (Right ())+sequenceNested (action : rest) = do+  result <- action+  case result of+    Left err -> pure (Left err)+    Right () -> sequenceNested rest+applySectionsCreate :: UUID -> [SectionNestedCreate] -> Db (Either ORMError ())+applySectionsCreate = insertSections+applySectionsUpdate :: UUID -> SectionsUpdate -> Db (Either ORMError ())+applySectionsUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceSections parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteSections parentId ops.delete+        , updateSectionsRows parentId ops.update+        , upsertSections parentId ops.upsert+        , insertSections parentId ops.create+        , insertSections parentId ops.createMany+        , connectSections parentId ops.connect+        ]+replaceSections :: UUID -> [SectionNestedCreate] -> Db (Either ORMError ())+replaceSections parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn sectionChapterRef <> " = ?") [toField parentId] (Delete.emptyDelete @SectionTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertSections parentId items+insertSections :: UUID -> [SectionNestedCreate] -> Db (Either ORMError ())+insertSections parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectSection key -> connectSections parentId [key]+        CreateSection {id, label} -> do+          inserted <- Insert.insert @SectionTable @SectionRow SectionCreate+            { id = id,+              label = label,+              chapterRef = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteSections :: UUID -> [Section.SectionUnique] -> Db (Either ORMError ())+deleteSections _ [] = pure (Right ())+deleteSections parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @SectionTable+        (Section.sectionUniqueWhere key `and_` eq sectionChapterRef parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateSectionsRows :: UUID -> [(Section.SectionUnique, SectionUpdate)] -> Db (Either ORMError ())+updateSectionsRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = SectionUpdate { chapterRef = Nothing, label = nested.label }+      result <-+        Update.updateWhere @SectionTable @SectionRow+          (Section.sectionUniqueWhere key `and_` eq sectionChapterRef parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertSections :: UUID -> [SectionNestedUpsert] -> Db (Either ORMError ())+upsertSections parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @SectionTable @SectionRow (matching (Section.sectionUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertSections parentId [item.create]+        Right (Just row) ->+          if row.chapterRef == parentId+            then do+              let patched = SectionUpdate { chapterRef = Nothing, label = item.update.label }+              updated <-+                Update.updateWhere @SectionTable @SectionRow+                  (Section.sectionUniqueWhere item.where_ `and_` eq sectionChapterRef parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectSections :: UUID -> [Section.SectionUnique] -> Db (Either ORMError ())+connectSections _ [] = pure (Right ())+connectSections parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @SectionTable @SectionRow+          (Section.sectionUniqueWhere key)+          (SectionUpdate+            { chapterRef = Just parentId,+              label = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()++data ChapterQuery include select = ChapterQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where ChapterTable)+  , orderBy_ :: [OrderBy ChapterTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data ChapterUniqueQuery include select = ChapterUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: ChapterUnique+  }++emptyQuery :: ChapterQuery () OmitSelect+emptyQuery =+  ChapterQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: ChapterUnique -> ChapterUniqueQuery () OmitSelect+uniqueQuery key =+  ChapterUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadChapter include select where+  findMany :: ChapterQuery include select -> Db [ChapterRead include select]+  findUnique :: ChapterUniqueQuery include select -> Db (Either ORMError (Maybe (ChapterRead include select)))+  findUniqueOrFail :: ChapterUniqueQuery include select -> Db (Either ORMError (ChapterRead include select))+  findFirst :: ChapterQuery include select -> Db (Maybe (ChapterRead include select))+  findFirstOrFail :: ChapterQuery include select -> Db (Either ORMError (ChapterRead include select))++instance (LoadChapter sections) => ReadChapter (ChapterInclude sections) OmitSelect where+  findMany ChapterQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadChapter include_ roots+  findUnique ChapterUniqueQuery {where_, include_} = do+    let w = chapterUniqueWhere where_+    roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (matching w))+    rows <- loadChapter include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ChapterQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadChapter include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadChapter () OmitSelect where+  findMany ChapterQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @ChapterTable @ChapterRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique ChapterUniqueQuery {where_} = do+    let w = chapterUniqueWhere where_+    rows <- Ops.findMany @ChapterTable @ChapterRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ChapterQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @ChapterTable @ChapterRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadChapter sections) => ReadChapter (ChapterInclude sections) ChapterSelect where+  findMany ChapterQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadChapter include_ roots+    pure $ map (toChapterWithPicked select_) loaded+  findUnique ChapterUniqueQuery {where_, include_, select_} = do+    let w = chapterUniqueWhere where_+    roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (matching w))+    loaded <- loadChapter include_ roots+    let rows = map (toChapterWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ChapterQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadChapter include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toChapterWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadChapter () ChapterSelect where+  findMany ChapterQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parseChapterPicked select_)+      (selectColumns (chapterSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique ChapterUniqueQuery {where_, select_} = do+    let w = chapterUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseChapterPicked select_)+        (selectColumns (chapterSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ChapterQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parseChapterPicked select_)+      (selectColumns (chapterSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: ChapterQuery include select -> Db Int+count ChapterQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @ChapterTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: ChapterUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @ChapterTable (chapterUniqueWhere key)++deleteMany :: Where ChapterTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @ChapterTable
+ test/Schema/Client/Comment.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.++Nested writes live on 'create' / 'update'.+  create-time relation fields are [CreateChild | ConnectChild unique]+  update-time relation fields are Maybe <Rel>Update (replaceWith, create, connect, delete, update, upsert;+  disconnect when the child foreign key is nullable)+-}+module Schema.Client.Comment+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    CommentCreateScalars,+    CommentUpdateScalars,+    CommentNestedCreate (..),+    CommentNestedUpsert (..),+    RepliesUpdate (..),+    emptyRepliesUpdate,+    CommentQuery (..),+    CommentUnique (..),+    CommentUniqueKey (..),+    CommentUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    commentUniqueWhere,+    OmitSelect (..),+    Picked (..),+    CommentCreate (..),+    CommentRow (..),+    CommentSelect (..),+    CommentPicked (..),+    commentSelect,+    CommentUpdate (..),+    CommentTable,+    commentId+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    transactionEither,+    fieldColumn,+    toField,+    NullableValue (..),+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    and_,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Comment (CommentRow (..), CommentSelect (..), CommentPicked (..), commentSelect, commentSelectColumns, parseCommentPicked, CommentTable, commentId, commentParentId)+import qualified Schema.Comment as CommentSchema (CommentCreate (..), CommentUpdate (..))++import Schema.Include.Comment (LoadComment (..), CommentInclude (..), CommentRead, toCommentWithPicked)++data CommentUnique+  = ById UUID+  deriving (Eq, Show)++data CommentUniqueKey+  = OnId+  deriving (Eq, Show)++commentUniqueWhere :: CommentUnique -> Where CommentTable+commentUniqueWhere = \case+  ById v1 -> eq commentId v1++commentConflictCols :: CommentUniqueKey -> [Text]+commentConflictCols = \case+  OnId -> ["id"]++data CommentNestedCreate+  = CreateComment+      { id :: Maybe UUID, body :: Text+      }+  | ConnectComment CommentUnique+  deriving (Show, Eq)+data CommentNestedUpsert = CommentNestedUpsert+  { where_ :: CommentUnique+  , create :: CommentNestedCreate+  , update :: CommentSchema.CommentUpdate+  }+  deriving (Show, Eq)+data RepliesUpdate = RepliesUpdate+  { replaceWith :: Maybe [CommentNestedCreate]+  , create :: [CommentNestedCreate]+  , createMany :: [CommentNestedCreate]+  , connect :: [CommentUnique]+  , delete :: [CommentUnique]+  , update :: [(CommentUnique, CommentSchema.CommentUpdate)]+  , upsert :: [CommentNestedUpsert]+  , disconnect :: [CommentUnique]+  }+  deriving (Show, Eq)++emptyRepliesUpdate :: RepliesUpdate+emptyRepliesUpdate =+  RepliesUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    , disconnect = []+    }+data CommentCreate = CommentCreate+  { id :: Maybe UUID,+    parentId :: NullableValue UUID,+    body :: Text,+    replies :: [CommentNestedCreate]+  }+  deriving (Show, Eq)++type CommentCreateScalars = CommentSchema.CommentCreate++toCommentCreateScalars :: CommentCreate -> CommentCreateScalars+toCommentCreateScalars input =+  CommentSchema.CommentCreate+    { id = input.id,+      parentId = input.parentId,+      body = input.body+    }+data CommentUpdate = CommentUpdate+  { parentId :: NullableValue UUID,+    body :: Maybe Text,+    replies :: Maybe RepliesUpdate+  }+  deriving (Show, Eq)++type CommentUpdateScalars = CommentSchema.CommentUpdate++toCommentUpdateScalars :: CommentUpdate -> CommentUpdateScalars+toCommentUpdateScalars input =+  CommentSchema.CommentUpdate+    { parentId = input.parentId,+      body = input.body+    }++create :: CommentCreate -> Db (Either ORMError CommentRow)+create input =+  if hasCommentNestedCreate input+    then transactionEither (createWithNested input)+    else Insert.insert @CommentTable @CommentRow (toCommentCreateScalars input)++hasCommentNestedCreate :: CommentCreate -> Bool+hasCommentNestedCreate input =+  not (null input.replies)++createWithNested :: CommentCreate -> Db (Either ORMError CommentRow)+createWithNested input = do+  rootResult <- Insert.insert @CommentTable @CommentRow (toCommentCreateScalars input)+  case rootResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ applyRepliesCreate row.id input.replies+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++createMany :: [CommentCreateScalars] -> Db (Either ORMError Int)+createMany = Insert.insertMany @CommentTable++update :: CommentUnique -> CommentUpdate -> Db (Either ORMError CommentRow)+update key input =+  if hasCommentNestedUpdate input+    then transactionEither (updateWithNested key input)+    else Update.updateWhere @CommentTable @CommentRow (commentUniqueWhere key) (toCommentUpdateScalars input)++hasCommentNestedUpdate :: CommentUpdate -> Bool+hasCommentNestedUpdate input =+  isJust input.replies++updateWithNested :: CommentUnique -> CommentUpdate -> Db (Either ORMError CommentRow)+updateWithNested key input = do+  updateResult <- Update.updateWhere @CommentTable @CommentRow (commentUniqueWhere key) (toCommentUpdateScalars input)+  case updateResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ maybe (pure (Right ())) (applyRepliesUpdate row.id) input.replies+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++updateMany :: Where CommentTable -> CommentUpdateScalars -> Db (Either ORMError Int)+updateMany = Update.updateMany @CommentTable++upsert :: CommentUniqueKey -> CommentCreateScalars -> CommentUpdateScalars -> Db (Either ORMError CommentRow)+upsert key createInput updateInput =+  Insert.upsert @CommentTable @CommentRow (commentConflictCols key) createInput updateInput++sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ())+sequenceNested [] = pure (Right ())+sequenceNested (action : rest) = do+  result <- action+  case result of+    Left err -> pure (Left err)+    Right () -> sequenceNested rest+applyRepliesCreate :: UUID -> [CommentNestedCreate] -> Db (Either ORMError ())+applyRepliesCreate = insertReplies+applyRepliesUpdate :: UUID -> RepliesUpdate -> Db (Either ORMError ())+applyRepliesUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceReplies parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteReplies parentId ops.delete+        , updateRepliesRows parentId ops.update+        , upsertReplies parentId ops.upsert+        , insertReplies parentId ops.create+        , insertReplies parentId ops.createMany+        , connectReplies parentId ops.connect+        , disconnectReplies parentId ops.disconnect+        ]+replaceReplies :: UUID -> [CommentNestedCreate] -> Db (Either ORMError ())+replaceReplies parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn commentParentId <> " = ?") [toField parentId] (Delete.emptyDelete @CommentTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertReplies parentId items+insertReplies :: UUID -> [CommentNestedCreate] -> Db (Either ORMError ())+insertReplies parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectComment key -> connectReplies parentId [key]+        CreateComment {id, body} -> do+          inserted <- Insert.insert @CommentTable @CommentRow CommentSchema.CommentCreate+            { id = id,+              body = body,+              parentId = Value parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteReplies :: UUID -> [CommentUnique] -> Db (Either ORMError ())+deleteReplies _ [] = pure (Right ())+deleteReplies parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @CommentTable+        (commentUniqueWhere key `and_` eq commentParentId parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateRepliesRows :: UUID -> [(CommentUnique, CommentSchema.CommentUpdate)] -> Db (Either ORMError ())+updateRepliesRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = CommentSchema.CommentUpdate { parentId = Omit, body = nested.body }+      result <-+        Update.updateWhere @CommentTable @CommentRow+          (commentUniqueWhere key `and_` eq commentParentId parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertReplies :: UUID -> [CommentNestedUpsert] -> Db (Either ORMError ())+upsertReplies parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @CommentTable @CommentRow (matching (commentUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertReplies parentId [item.create]+        Right (Just row) ->+          if row.parentId == Just parentId+            then do+              let patched = CommentSchema.CommentUpdate { parentId = Omit, body = item.update.body }+              updated <-+                Update.updateWhere @CommentTable @CommentRow+                  (commentUniqueWhere item.where_ `and_` eq commentParentId parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectReplies :: UUID -> [CommentUnique] -> Db (Either ORMError ())+connectReplies _ [] = pure (Right ())+connectReplies parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @CommentTable @CommentRow+          (commentUniqueWhere key)+          (CommentSchema.CommentUpdate+            { parentId = Value parentId,+              body = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+disconnectReplies :: UUID -> [CommentUnique] -> Db (Either ORMError ())+disconnectReplies _ [] = pure (Right ())+disconnectReplies parentId keys = sequenceNested (map disconnectOne keys)+  where+    disconnectOne key = do+      result <-+        Update.updateWhere @CommentTable @CommentRow+          (commentUniqueWhere key `and_` eq commentParentId parentId)+          (CommentSchema.CommentUpdate+            { parentId = Null,+              body = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()++data CommentQuery include select = CommentQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where CommentTable)+  , orderBy_ :: [OrderBy CommentTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data CommentUniqueQuery include select = CommentUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: CommentUnique+  }++emptyQuery :: CommentQuery () OmitSelect+emptyQuery =+  CommentQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: CommentUnique -> CommentUniqueQuery () OmitSelect+uniqueQuery key =+  CommentUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadComment include select where+  findMany :: CommentQuery include select -> Db [CommentRead include select]+  findUnique :: CommentUniqueQuery include select -> Db (Either ORMError (Maybe (CommentRead include select)))+  findUniqueOrFail :: CommentUniqueQuery include select -> Db (Either ORMError (CommentRead include select))+  findFirst :: CommentQuery include select -> Db (Maybe (CommentRead include select))+  findFirstOrFail :: CommentQuery include select -> Db (Either ORMError (CommentRead include select))++instance (LoadComment replies) => ReadComment (CommentInclude replies) OmitSelect where+  findMany CommentQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadComment include_ roots+  findUnique CommentUniqueQuery {where_, include_} = do+    let w = commentUniqueWhere where_+    roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (matching w))+    rows <- loadComment include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst CommentQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadComment include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadComment () OmitSelect where+  findMany CommentQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @CommentTable @CommentRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique CommentUniqueQuery {where_} = do+    let w = commentUniqueWhere where_+    rows <- Ops.findMany @CommentTable @CommentRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst CommentQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @CommentTable @CommentRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadComment replies) => ReadComment (CommentInclude replies) CommentSelect where+  findMany CommentQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadComment include_ roots+    pure $ map (toCommentWithPicked select_) loaded+  findUnique CommentUniqueQuery {where_, include_, select_} = do+    let w = commentUniqueWhere where_+    roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (matching w))+    loaded <- loadComment include_ roots+    let rows = map (toCommentWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst CommentQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadComment include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toCommentWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadComment () CommentSelect where+  findMany CommentQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parseCommentPicked select_)+      (selectColumns (commentSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique CommentUniqueQuery {where_, select_} = do+    let w = commentUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseCommentPicked select_)+        (selectColumns (commentSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst CommentQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parseCommentPicked select_)+      (selectColumns (commentSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: CommentQuery include select -> Db Int+count CommentQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @CommentTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: CommentUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @CommentTable (commentUniqueWhere key)++deleteMany :: Where CommentTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @CommentTable
+ test/Schema/Client/Editor.hs view
@@ -0,0 +1,618 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.++Nested writes live on 'create' / 'update'.+  create-time relation fields are [CreateChild | ConnectChild unique]+  update-time relation fields are Maybe <Rel>Update (replaceWith, create, connect, delete, update, upsert;+  disconnect when the child foreign key is nullable)+-}+module Schema.Client.Editor+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    EditorCreateScalars,+    EditorUpdateScalars,+    ArticleNestedCreate (..),+    ArticleNestedUpsert (..),+    WrittenPostsUpdate (..),+    emptyWrittenPostsUpdate,+    EditedPostsUpdate (..),+    emptyEditedPostsUpdate,+    EditorQuery (..),+    EditorUnique (..),+    EditorUniqueKey (..),+    EditorUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    editorUniqueWhere,+    OmitSelect (..),+    Picked (..),+    EditorCreate (..),+    EditorRow (..),+    EditorSelect (..),+    EditorPicked (..),+    editorSelect,+    EditorUpdate (..),+    EditorTable,+    editorId+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    transactionEither,+    fieldColumn,+    toField,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    and_,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Editor (EditorRow (..), EditorSelect (..), EditorPicked (..), editorSelect, editorSelectColumns, parseEditorPicked, EditorTable, editorId)+import qualified Schema.Editor as EditorSchema (EditorCreate (..), EditorUpdate (..))++import Schema.Include.Editor (LoadEditor (..), EditorInclude (..), EditorRead, toEditorWithPicked)+import Schema.Article (ArticleRow (..), ArticleTable, articleId, articleAuthorId, ArticleCreate (..), ArticleUpdate (..))+import qualified Schema.Client.Article as Article (ArticleUnique (..), articleUniqueWhere)++data EditorUnique+  = ById UUID+  deriving (Eq, Show)++data EditorUniqueKey+  = OnId+  deriving (Eq, Show)++editorUniqueWhere :: EditorUnique -> Where EditorTable+editorUniqueWhere = \case+  ById v1 -> eq editorId v1++editorConflictCols :: EditorUniqueKey -> [Text]+editorConflictCols = \case+  OnId -> ["id"]++data ArticleNestedCreate+  = CreateArticle+      { id :: Maybe UUID, title :: Text+      }+  | ConnectArticle Article.ArticleUnique+  deriving (Show, Eq)+data ArticleNestedUpsert = ArticleNestedUpsert+  { where_ :: Article.ArticleUnique+  , create :: ArticleNestedCreate+  , update :: ArticleUpdate+  }+  deriving (Show, Eq)+data WrittenPostsUpdate = WrittenPostsUpdate+  { replaceWith :: Maybe [ArticleNestedCreate]+  , create :: [ArticleNestedCreate]+  , createMany :: [ArticleNestedCreate]+  , connect :: [Article.ArticleUnique]+  , delete :: [Article.ArticleUnique]+  , update :: [(Article.ArticleUnique, ArticleUpdate)]+  , upsert :: [ArticleNestedUpsert]+  }+  deriving (Show, Eq)++emptyWrittenPostsUpdate :: WrittenPostsUpdate+emptyWrittenPostsUpdate =+  WrittenPostsUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data EditedPostsUpdate = EditedPostsUpdate+  { replaceWith :: Maybe [ArticleNestedCreate]+  , create :: [ArticleNestedCreate]+  , createMany :: [ArticleNestedCreate]+  , connect :: [Article.ArticleUnique]+  , delete :: [Article.ArticleUnique]+  , update :: [(Article.ArticleUnique, ArticleUpdate)]+  , upsert :: [ArticleNestedUpsert]+  }+  deriving (Show, Eq)++emptyEditedPostsUpdate :: EditedPostsUpdate+emptyEditedPostsUpdate =+  EditedPostsUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data EditorCreate = EditorCreate+  { id :: Maybe UUID,+    name :: Text,+    writtenPosts :: [ArticleNestedCreate],+    editedPosts :: [ArticleNestedCreate]+  }+  deriving (Show, Eq)++type EditorCreateScalars = EditorSchema.EditorCreate++toEditorCreateScalars :: EditorCreate -> EditorCreateScalars+toEditorCreateScalars input =+  EditorSchema.EditorCreate+    { id = input.id,+      name = input.name+    }+data EditorUpdate = EditorUpdate+  { name :: Maybe Text,+    writtenPosts :: Maybe WrittenPostsUpdate,+    editedPosts :: Maybe EditedPostsUpdate+  }+  deriving (Show, Eq)++type EditorUpdateScalars = EditorSchema.EditorUpdate++toEditorUpdateScalars :: EditorUpdate -> EditorUpdateScalars+toEditorUpdateScalars input =+  EditorSchema.EditorUpdate+    { name = input.name+    }++create :: EditorCreate -> Db (Either ORMError EditorRow)+create input =+  if hasEditorNestedCreate input+    then transactionEither (createWithNested input)+    else Insert.insert @EditorTable @EditorRow (toEditorCreateScalars input)++hasEditorNestedCreate :: EditorCreate -> Bool+hasEditorNestedCreate input =+  not (null input.writtenPosts) || not (null input.editedPosts)++createWithNested :: EditorCreate -> Db (Either ORMError EditorRow)+createWithNested input = do+  rootResult <- Insert.insert @EditorTable @EditorRow (toEditorCreateScalars input)+  case rootResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ applyWrittenPostsCreate row.id input.writtenPosts+          , applyEditedPostsCreate row.id input.editedPosts+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++createMany :: [EditorCreateScalars] -> Db (Either ORMError Int)+createMany = Insert.insertMany @EditorTable++update :: EditorUnique -> EditorUpdate -> Db (Either ORMError EditorRow)+update key input =+  if hasEditorNestedUpdate input+    then transactionEither (updateWithNested key input)+    else Update.updateWhere @EditorTable @EditorRow (editorUniqueWhere key) (toEditorUpdateScalars input)++hasEditorNestedUpdate :: EditorUpdate -> Bool+hasEditorNestedUpdate input =+  isJust input.writtenPosts || isJust input.editedPosts++updateWithNested :: EditorUnique -> EditorUpdate -> Db (Either ORMError EditorRow)+updateWithNested key input = do+  updateResult <- Update.updateWhere @EditorTable @EditorRow (editorUniqueWhere key) (toEditorUpdateScalars input)+  case updateResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ maybe (pure (Right ())) (applyWrittenPostsUpdate row.id) input.writtenPosts+          , maybe (pure (Right ())) (applyEditedPostsUpdate row.id) input.editedPosts+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++updateMany :: Where EditorTable -> EditorUpdateScalars -> Db (Either ORMError Int)+updateMany = Update.updateMany @EditorTable++upsert :: EditorUniqueKey -> EditorCreateScalars -> EditorUpdateScalars -> Db (Either ORMError EditorRow)+upsert key createInput updateInput =+  Insert.upsert @EditorTable @EditorRow (editorConflictCols key) createInput updateInput++sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ())+sequenceNested [] = pure (Right ())+sequenceNested (action : rest) = do+  result <- action+  case result of+    Left err -> pure (Left err)+    Right () -> sequenceNested rest+applyWrittenPostsCreate :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ())+applyWrittenPostsCreate = insertWrittenPosts+applyWrittenPostsUpdate :: UUID -> WrittenPostsUpdate -> Db (Either ORMError ())+applyWrittenPostsUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceWrittenPosts parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteWrittenPosts parentId ops.delete+        , updateWrittenPostsRows parentId ops.update+        , upsertWrittenPosts parentId ops.upsert+        , insertWrittenPosts parentId ops.create+        , insertWrittenPosts parentId ops.createMany+        , connectWrittenPosts parentId ops.connect+        ]+replaceWrittenPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ())+replaceWrittenPosts parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn articleAuthorId <> " = ?") [toField parentId] (Delete.emptyDelete @ArticleTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertWrittenPosts parentId items+insertWrittenPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ())+insertWrittenPosts parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectArticle key -> connectWrittenPosts parentId [key]+        CreateArticle {id, title} -> do+          inserted <- Insert.insert @ArticleTable @ArticleRow ArticleCreate+            { id = id,+              title = title,+              authorId = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteWrittenPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ())+deleteWrittenPosts _ [] = pure (Right ())+deleteWrittenPosts parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @ArticleTable+        (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateWrittenPostsRows :: UUID -> [(Article.ArticleUnique, ArticleUpdate)] -> Db (Either ORMError ())+updateWrittenPostsRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = ArticleUpdate { authorId = Nothing, title = nested.title }+      result <-+        Update.updateWhere @ArticleTable @ArticleRow+          (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertWrittenPosts :: UUID -> [ArticleNestedUpsert] -> Db (Either ORMError ())+upsertWrittenPosts parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @ArticleTable @ArticleRow (matching (Article.articleUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertWrittenPosts parentId [item.create]+        Right (Just row) ->+          if row.authorId == parentId+            then do+              let patched = ArticleUpdate { authorId = Nothing, title = item.update.title }+              updated <-+                Update.updateWhere @ArticleTable @ArticleRow+                  (Article.articleUniqueWhere item.where_ `and_` eq articleAuthorId parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectWrittenPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ())+connectWrittenPosts _ [] = pure (Right ())+connectWrittenPosts parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @ArticleTable @ArticleRow+          (Article.articleUniqueWhere key)+          (ArticleUpdate+            { authorId = Just parentId,+              title = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+applyEditedPostsCreate :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ())+applyEditedPostsCreate = insertEditedPosts+applyEditedPostsUpdate :: UUID -> EditedPostsUpdate -> Db (Either ORMError ())+applyEditedPostsUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceEditedPosts parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteEditedPosts parentId ops.delete+        , updateEditedPostsRows parentId ops.update+        , upsertEditedPosts parentId ops.upsert+        , insertEditedPosts parentId ops.create+        , insertEditedPosts parentId ops.createMany+        , connectEditedPosts parentId ops.connect+        ]+replaceEditedPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ())+replaceEditedPosts parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn articleAuthorId <> " = ?") [toField parentId] (Delete.emptyDelete @ArticleTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertEditedPosts parentId items+insertEditedPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ())+insertEditedPosts parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectArticle key -> connectEditedPosts parentId [key]+        CreateArticle {id, title} -> do+          inserted <- Insert.insert @ArticleTable @ArticleRow ArticleCreate+            { id = id,+              title = title,+              authorId = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteEditedPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ())+deleteEditedPosts _ [] = pure (Right ())+deleteEditedPosts parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @ArticleTable+        (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateEditedPostsRows :: UUID -> [(Article.ArticleUnique, ArticleUpdate)] -> Db (Either ORMError ())+updateEditedPostsRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = ArticleUpdate { authorId = Nothing, title = nested.title }+      result <-+        Update.updateWhere @ArticleTable @ArticleRow+          (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertEditedPosts :: UUID -> [ArticleNestedUpsert] -> Db (Either ORMError ())+upsertEditedPosts parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @ArticleTable @ArticleRow (matching (Article.articleUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertEditedPosts parentId [item.create]+        Right (Just row) ->+          if row.authorId == parentId+            then do+              let patched = ArticleUpdate { authorId = Nothing, title = item.update.title }+              updated <-+                Update.updateWhere @ArticleTable @ArticleRow+                  (Article.articleUniqueWhere item.where_ `and_` eq articleAuthorId parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectEditedPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ())+connectEditedPosts _ [] = pure (Right ())+connectEditedPosts parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @ArticleTable @ArticleRow+          (Article.articleUniqueWhere key)+          (ArticleUpdate+            { authorId = Just parentId,+              title = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()++data EditorQuery include select = EditorQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where EditorTable)+  , orderBy_ :: [OrderBy EditorTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data EditorUniqueQuery include select = EditorUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: EditorUnique+  }++emptyQuery :: EditorQuery () OmitSelect+emptyQuery =+  EditorQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: EditorUnique -> EditorUniqueQuery () OmitSelect+uniqueQuery key =+  EditorUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadEditor include select where+  findMany :: EditorQuery include select -> Db [EditorRead include select]+  findUnique :: EditorUniqueQuery include select -> Db (Either ORMError (Maybe (EditorRead include select)))+  findUniqueOrFail :: EditorUniqueQuery include select -> Db (Either ORMError (EditorRead include select))+  findFirst :: EditorQuery include select -> Db (Maybe (EditorRead include select))+  findFirstOrFail :: EditorQuery include select -> Db (Either ORMError (EditorRead include select))++instance (LoadEditor writtenPosts editedPosts) => ReadEditor (EditorInclude writtenPosts editedPosts) OmitSelect where+  findMany EditorQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadEditor include_ roots+  findUnique EditorUniqueQuery {where_, include_} = do+    let w = editorUniqueWhere where_+    roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (matching w))+    rows <- loadEditor include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst EditorQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadEditor include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadEditor () OmitSelect where+  findMany EditorQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @EditorTable @EditorRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique EditorUniqueQuery {where_} = do+    let w = editorUniqueWhere where_+    rows <- Ops.findMany @EditorTable @EditorRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst EditorQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @EditorTable @EditorRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadEditor writtenPosts editedPosts) => ReadEditor (EditorInclude writtenPosts editedPosts) EditorSelect where+  findMany EditorQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadEditor include_ roots+    pure $ map (toEditorWithPicked select_) loaded+  findUnique EditorUniqueQuery {where_, include_, select_} = do+    let w = editorUniqueWhere where_+    roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (matching w))+    loaded <- loadEditor include_ roots+    let rows = map (toEditorWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst EditorQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadEditor include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toEditorWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadEditor () EditorSelect where+  findMany EditorQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parseEditorPicked select_)+      (selectColumns (editorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique EditorUniqueQuery {where_, select_} = do+    let w = editorUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseEditorPicked select_)+        (selectColumns (editorSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst EditorQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parseEditorPicked select_)+      (selectColumns (editorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: EditorQuery include select -> Db Int+count EditorQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @EditorTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: EditorUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @EditorTable (editorUniqueWhere key)++deleteMany :: Where EditorTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @EditorTable
+ test/Schema/Client/Post.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.+-}+module Schema.Client.Post+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    PostQuery (..),+    PostUnique (..),+    PostUniqueKey (..),+    PostUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    postUniqueWhere,+    OmitSelect (..),+    Picked (..),+    PostCreate (..),+    PostRow (..),+    PostSelect (..),+    PostPicked (..),+    postSelect,+    PostUpdate (..),+    PostTable,+    postId+  )+where++import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Post (PostCreate (..), PostUpdate (..), PostRow (..), PostSelect (..), PostPicked (..), postSelect, postSelectColumns, parsePostPicked, PostTable, postId)+import Schema.Include.Post (LoadPost (..), PostInclude (..), PostRead, toPostWithPicked)+import Data.Text (Text)++data PostUnique+  = ById UUID+  deriving (Eq, Show)++data PostUniqueKey+  = OnId+  deriving (Eq, Show)++postUniqueWhere :: PostUnique -> Where PostTable+postUniqueWhere = \case+  ById v1 -> eq postId v1++postConflictCols :: PostUniqueKey -> [Text]+postConflictCols = \case+  OnId -> ["id"]++create :: PostCreate -> Db (Either ORMError PostRow)+create = Insert.insert @PostTable @PostRow++createMany :: [PostCreate] -> Db (Either ORMError Int)+createMany = Insert.insertMany @PostTable++update :: PostUnique -> PostUpdate -> Db (Either ORMError PostRow)+update key input =+  Update.updateWhere @PostTable @PostRow (postUniqueWhere key) input++updateMany :: Where PostTable -> PostUpdate -> Db (Either ORMError Int)+updateMany = Update.updateMany @PostTable++upsert :: PostUniqueKey -> PostCreate -> PostUpdate -> Db (Either ORMError PostRow)+upsert key createInput updateInput =+  Insert.upsert @PostTable @PostRow (postConflictCols key) createInput updateInput++data PostQuery include select = PostQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where PostTable)+  , orderBy_ :: [OrderBy PostTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data PostUniqueQuery include select = PostUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: PostUnique+  }++emptyQuery :: PostQuery () OmitSelect+emptyQuery =+  PostQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: PostUnique -> PostUniqueQuery () OmitSelect+uniqueQuery key =+  PostUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadPost include select where+  findMany :: PostQuery include select -> Db [PostRead include select]+  findUnique :: PostUniqueQuery include select -> Db (Either ORMError (Maybe (PostRead include select)))+  findUniqueOrFail :: PostUniqueQuery include select -> Db (Either ORMError (PostRead include select))+  findFirst :: PostQuery include select -> Db (Maybe (PostRead include select))+  findFirstOrFail :: PostQuery include select -> Db (Either ORMError (PostRead include select))++instance (LoadPost author) => ReadPost (PostInclude author) OmitSelect where+  findMany PostQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadPost include_ roots+  findUnique PostUniqueQuery {where_, include_} = do+    let w = postUniqueWhere where_+    roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (matching w))+    rows <- loadPost include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst PostQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadPost include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadPost () OmitSelect where+  findMany PostQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @PostTable @PostRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique PostUniqueQuery {where_} = do+    let w = postUniqueWhere where_+    rows <- Ops.findMany @PostTable @PostRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst PostQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @PostTable @PostRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadPost author) => ReadPost (PostInclude author) PostSelect where+  findMany PostQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadPost include_ roots+    pure $ map (toPostWithPicked select_) loaded+  findUnique PostUniqueQuery {where_, include_, select_} = do+    let w = postUniqueWhere where_+    roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (matching w))+    loaded <- loadPost include_ roots+    let rows = map (toPostWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst PostQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadPost include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toPostWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadPost () PostSelect where+  findMany PostQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parsePostPicked select_)+      (selectColumns (postSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique PostUniqueQuery {where_, select_} = do+    let w = postUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parsePostPicked select_)+        (selectColumns (postSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst PostQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parsePostPicked select_)+      (selectColumns (postSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: PostQuery include select -> Db Int+count PostQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @PostTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: PostUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @PostTable (postUniqueWhere key)++deleteMany :: Where PostTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @PostTable
+ test/Schema/Client/Section.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Schema.Client.Section+  ( create,+    createMany,+    update,+    updateMany,+    upsert,+    findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    delete,+    deleteMany,+    SectionCreate (..),+    SectionRow (..),+    SectionSelect (..),+    SectionPicked (..),+    sectionSelect,+    OmitSelect (..),+    Picked (..),+    ResolveSelect,+    SectionUpdate (..),+    SectionTable,+    SectionQuery (..),+    SectionUnique (..),+    SectionUniqueKey (..),+    SectionUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    sectionUniqueWhere,+    sectionId+  )++where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    QueryBuilder,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    Where,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Section (SectionCreate (..), SectionRow (..), SectionSelect (..), SectionPicked (..), sectionSelect, sectionSelectColumns, parseSectionPicked, SectionTable, SectionUpdate (..), sectionId)++data SectionUnique+  = ById UUID+  deriving (Eq, Show)++data SectionUniqueKey+  = OnId+  deriving (Eq, Show)++sectionUniqueWhere :: SectionUnique -> Where SectionTable+sectionUniqueWhere = \case+  ById v1 -> eq sectionId v1++sectionConflictCols :: SectionUniqueKey -> [Text]+sectionConflictCols = \case+  OnId -> ["id"]+++create :: SectionCreate -> Db (Either ORMError SectionRow)+create = Insert.insert @SectionTable @SectionRow+++createMany :: [SectionCreate] -> Db (Either ORMError Int)+createMany = Insert.insertMany @SectionTable+++update :: SectionUnique -> SectionUpdate -> Db (Either ORMError SectionRow)+update key input =+  Update.updateWhere @SectionTable @SectionRow (sectionUniqueWhere key) input+++updateMany :: Where SectionTable -> SectionUpdate -> Db (Either ORMError Int)+updateMany = Update.updateMany @SectionTable+++upsert :: SectionUniqueKey -> SectionCreate -> SectionUpdate -> Db (Either ORMError SectionRow)+upsert key createInput updateInput =+  Insert.upsert @SectionTable @SectionRow (sectionConflictCols key) createInput updateInput+++data SectionQuery select = SectionQuery+  { select_ :: select+  , where_ :: Maybe (Where SectionTable)+  , orderBy_ :: [OrderBy SectionTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }+++data SectionUniqueQuery select = SectionUniqueQuery+  { select_ :: select+  , where_ :: SectionUnique+  }+++emptyQuery :: SectionQuery OmitSelect+emptyQuery =+  SectionQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}+++uniqueQuery :: SectionUnique -> SectionUniqueQuery OmitSelect+uniqueQuery key =+  SectionUniqueQuery {select_ = OmitSelect, where_ = key}+++type family ResolveSelect select+type instance ResolveSelect OmitSelect = SectionRow+type instance ResolveSelect SectionSelect = SectionPicked+++class ReadSection select where+  findMany :: SectionQuery select -> Db [ResolveSelect select]+  findUnique :: SectionUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select)))+  findUniqueOrFail :: SectionUniqueQuery select -> Db (Either ORMError (ResolveSelect select))+  findFirst :: SectionQuery select -> Db (Maybe (ResolveSelect select))+  findFirstOrFail :: SectionQuery select -> Db (Either ORMError (ResolveSelect select))++instance ReadSection OmitSelect where+  findMany q =+    Ops.findMany @SectionTable @SectionRow (applyQuery q)+  findUnique SectionUniqueQuery {where_} = do+    let w = sectionUniqueWhere where_+    rows <- Ops.findMany @SectionTable @SectionRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q =+    Ops.findFirst @SectionTable @SectionRow (applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadSection SectionSelect where+  findMany q@SectionQuery {select_} =+    Ops.findManyWith+      (parseSectionPicked select_)+      (selectColumns (sectionSelectColumns select_) . applyQuery q)+  findUnique SectionUniqueQuery {where_, select_} = do+    let w = sectionUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseSectionPicked select_)+        (selectColumns (sectionSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q@SectionQuery {select_} =+    Ops.findFirstWith+      (parseSectionPicked select_)+      (selectColumns (sectionSelectColumns select_) . applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++applyQuery :: SectionQuery select -> QueryBuilder SectionTable -> QueryBuilder SectionTable+applyQuery SectionQuery {where_, orderBy_, limit_, offset_} =+  applyQueryModifiers where_ orderBy_ limit_ offset_+++count :: SectionQuery select -> Db Int+count q = Ops.count @SectionTable (applyQuery q)+++delete :: SectionUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @SectionTable (sectionUniqueWhere key)+++deleteMany :: Where SectionTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @SectionTable+
+ test/Schema/Client/Shelf.hs view
@@ -0,0 +1,634 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- | Generated Client. Do not edit.++Nested writes live on 'create' / 'update'.+  create-time relation fields are [CreateChild | ConnectChild unique]+  update-time relation fields are Maybe <Rel>Update (replaceWith, create, connect, delete, update, upsert;+  disconnect when the child foreign key is nullable)+-}+module Schema.Client.Shelf+  ( findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    create,+    createMany,+    update,+    updateMany,+    upsert,+    delete,+    deleteMany,+    ShelfCreateScalars,+    ShelfUpdateScalars,+    BookNestedCreate (..),+    BookNestedUpsert (..),+    BooksUpdate (..),+    emptyBooksUpdate,+    TagNestedCreate (..),+    TagNestedUpsert (..),+    TagsUpdate (..),+    emptyTagsUpdate,+    ShelfQuery (..),+    ShelfUnique (..),+    ShelfUniqueKey (..),+    ShelfUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    shelfUniqueWhere,+    OmitSelect (..),+    Picked (..),+    ShelfCreate (..),+    ShelfRow (..),+    ShelfSelect (..),+    ShelfPicked (..),+    shelfSelect,+    ShelfUpdate (..),+    ShelfTable,+    shelfId+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    transactionEither,+    fieldColumn,+    toField,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    prepareIncludeRootQuery,+    Where,+    and_,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany,+    deleteWhere,+    whereDelete,+    emptyDelete+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Shelf (ShelfRow (..), ShelfSelect (..), ShelfPicked (..), shelfSelect, shelfSelectColumns, parseShelfPicked, ShelfTable, shelfId)+import qualified Schema.Shelf as ShelfSchema (ShelfCreate (..), ShelfUpdate (..))++import Schema.Include.Shelf (LoadShelf (..), ShelfInclude (..), ShelfRead, toShelfWithPicked)+import Schema.Book (BookRow (..), BookTable, bookId, bookShelfId, BookCreate (..), BookUpdate (..))+import Schema.Tag (TagRow (..), TagTable, tagId, tagShelfId, TagCreate (..), TagUpdate (..))+import qualified Schema.Client.Book as Book (BookUnique (..), bookUniqueWhere)+import qualified Schema.Client.Tag as Tag (TagUnique (..), tagUniqueWhere)++data ShelfUnique+  = ById UUID+  deriving (Eq, Show)++data ShelfUniqueKey+  = OnId+  deriving (Eq, Show)++shelfUniqueWhere :: ShelfUnique -> Where ShelfTable+shelfUniqueWhere = \case+  ById v1 -> eq shelfId v1++shelfConflictCols :: ShelfUniqueKey -> [Text]+shelfConflictCols = \case+  OnId -> ["id"]++data BookNestedCreate+  = CreateBook+      { id :: Maybe UUID, title :: Text+      }+  | ConnectBook Book.BookUnique+  deriving (Show, Eq)+data TagNestedCreate+  = CreateTag+      { id :: Maybe UUID, label :: Text+      }+  | ConnectTag Tag.TagUnique+  deriving (Show, Eq)+data BookNestedUpsert = BookNestedUpsert+  { where_ :: Book.BookUnique+  , create :: BookNestedCreate+  , update :: BookUpdate+  }+  deriving (Show, Eq)+data TagNestedUpsert = TagNestedUpsert+  { where_ :: Tag.TagUnique+  , create :: TagNestedCreate+  , update :: TagUpdate+  }+  deriving (Show, Eq)+data BooksUpdate = BooksUpdate+  { replaceWith :: Maybe [BookNestedCreate]+  , create :: [BookNestedCreate]+  , createMany :: [BookNestedCreate]+  , connect :: [Book.BookUnique]+  , delete :: [Book.BookUnique]+  , update :: [(Book.BookUnique, BookUpdate)]+  , upsert :: [BookNestedUpsert]+  }+  deriving (Show, Eq)++emptyBooksUpdate :: BooksUpdate+emptyBooksUpdate =+  BooksUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data TagsUpdate = TagsUpdate+  { replaceWith :: Maybe [TagNestedCreate]+  , create :: [TagNestedCreate]+  , createMany :: [TagNestedCreate]+  , connect :: [Tag.TagUnique]+  , delete :: [Tag.TagUnique]+  , update :: [(Tag.TagUnique, TagUpdate)]+  , upsert :: [TagNestedUpsert]+  }+  deriving (Show, Eq)++emptyTagsUpdate :: TagsUpdate+emptyTagsUpdate =+  TagsUpdate+    { replaceWith = Nothing+    , create = []+    , createMany = []+    , connect = []+    , delete = []+    , update = []+    , upsert = []+    }+data ShelfCreate = ShelfCreate+  { id :: Maybe UUID,+    name :: Text,+    books :: [BookNestedCreate],+    tags :: [TagNestedCreate]+  }+  deriving (Show, Eq)++type ShelfCreateScalars = ShelfSchema.ShelfCreate++toShelfCreateScalars :: ShelfCreate -> ShelfCreateScalars+toShelfCreateScalars input =+  ShelfSchema.ShelfCreate+    { id = input.id,+      name = input.name+    }+data ShelfUpdate = ShelfUpdate+  { name :: Maybe Text,+    books :: Maybe BooksUpdate,+    tags :: Maybe TagsUpdate+  }+  deriving (Show, Eq)++type ShelfUpdateScalars = ShelfSchema.ShelfUpdate++toShelfUpdateScalars :: ShelfUpdate -> ShelfUpdateScalars+toShelfUpdateScalars input =+  ShelfSchema.ShelfUpdate+    { name = input.name+    }++create :: ShelfCreate -> Db (Either ORMError ShelfRow)+create input =+  if hasShelfNestedCreate input+    then transactionEither (createWithNested input)+    else Insert.insert @ShelfTable @ShelfRow (toShelfCreateScalars input)++hasShelfNestedCreate :: ShelfCreate -> Bool+hasShelfNestedCreate input =+  not (null input.books) || not (null input.tags)++createWithNested :: ShelfCreate -> Db (Either ORMError ShelfRow)+createWithNested input = do+  rootResult <- Insert.insert @ShelfTable @ShelfRow (toShelfCreateScalars input)+  case rootResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ applyBooksCreate row.id input.books+          , applyTagsCreate row.id input.tags+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++createMany :: [ShelfCreateScalars] -> Db (Either ORMError Int)+createMany = Insert.insertMany @ShelfTable++update :: ShelfUnique -> ShelfUpdate -> Db (Either ORMError ShelfRow)+update key input =+  if hasShelfNestedUpdate input+    then transactionEither (updateWithNested key input)+    else Update.updateWhere @ShelfTable @ShelfRow (shelfUniqueWhere key) (toShelfUpdateScalars input)++hasShelfNestedUpdate :: ShelfUpdate -> Bool+hasShelfNestedUpdate input =+  isJust input.books || isJust input.tags++updateWithNested :: ShelfUnique -> ShelfUpdate -> Db (Either ORMError ShelfRow)+updateWithNested key input = do+  updateResult <- Update.updateWhere @ShelfTable @ShelfRow (shelfUniqueWhere key) (toShelfUpdateScalars input)+  case updateResult of+    Left err -> pure (Left err)+    Right row -> do+      nestedResult <-+        sequenceNested+          [ maybe (pure (Right ())) (applyBooksUpdate row.id) input.books+          , maybe (pure (Right ())) (applyTagsUpdate row.id) input.tags+          ]+      case nestedResult of+        Left err -> pure (Left err)+        Right () -> pure (Right row)++updateMany :: Where ShelfTable -> ShelfUpdateScalars -> Db (Either ORMError Int)+updateMany = Update.updateMany @ShelfTable++upsert :: ShelfUniqueKey -> ShelfCreateScalars -> ShelfUpdateScalars -> Db (Either ORMError ShelfRow)+upsert key createInput updateInput =+  Insert.upsert @ShelfTable @ShelfRow (shelfConflictCols key) createInput updateInput++sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ())+sequenceNested [] = pure (Right ())+sequenceNested (action : rest) = do+  result <- action+  case result of+    Left err -> pure (Left err)+    Right () -> sequenceNested rest+applyBooksCreate :: UUID -> [BookNestedCreate] -> Db (Either ORMError ())+applyBooksCreate = insertBooks+applyBooksUpdate :: UUID -> BooksUpdate -> Db (Either ORMError ())+applyBooksUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceBooks parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteBooks parentId ops.delete+        , updateBooksRows parentId ops.update+        , upsertBooks parentId ops.upsert+        , insertBooks parentId ops.create+        , insertBooks parentId ops.createMany+        , connectBooks parentId ops.connect+        ]+replaceBooks :: UUID -> [BookNestedCreate] -> Db (Either ORMError ())+replaceBooks parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn bookShelfId <> " = ?") [toField parentId] (Delete.emptyDelete @BookTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertBooks parentId items+insertBooks :: UUID -> [BookNestedCreate] -> Db (Either ORMError ())+insertBooks parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectBook key -> connectBooks parentId [key]+        CreateBook {id, title} -> do+          inserted <- Insert.insert @BookTable @BookRow BookCreate+            { id = id,+              title = title,+              shelfId = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteBooks :: UUID -> [Book.BookUnique] -> Db (Either ORMError ())+deleteBooks _ [] = pure (Right ())+deleteBooks parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @BookTable+        (Book.bookUniqueWhere key `and_` eq bookShelfId parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateBooksRows :: UUID -> [(Book.BookUnique, BookUpdate)] -> Db (Either ORMError ())+updateBooksRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = BookUpdate { shelfId = Nothing, title = nested.title }+      result <-+        Update.updateWhere @BookTable @BookRow+          (Book.bookUniqueWhere key `and_` eq bookShelfId parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertBooks :: UUID -> [BookNestedUpsert] -> Db (Either ORMError ())+upsertBooks parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @BookTable @BookRow (matching (Book.bookUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertBooks parentId [item.create]+        Right (Just row) ->+          if row.shelfId == parentId+            then do+              let patched = BookUpdate { shelfId = Nothing, title = item.update.title }+              updated <-+                Update.updateWhere @BookTable @BookRow+                  (Book.bookUniqueWhere item.where_ `and_` eq bookShelfId parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectBooks :: UUID -> [Book.BookUnique] -> Db (Either ORMError ())+connectBooks _ [] = pure (Right ())+connectBooks parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @BookTable @BookRow+          (Book.bookUniqueWhere key)+          (BookUpdate+            { shelfId = Just parentId,+              title = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+applyTagsCreate :: UUID -> [TagNestedCreate] -> Db (Either ORMError ())+applyTagsCreate = insertTags+applyTagsUpdate :: UUID -> TagsUpdate -> Db (Either ORMError ())+applyTagsUpdate parentId ops = do+  replaced <- case ops.replaceWith of+    Nothing -> pure (Right ())+    Just items -> replaceTags parentId items+  case replaced of+    Left err -> pure (Left err)+    Right () ->+      sequenceNested+        [ deleteTags parentId ops.delete+        , updateTagsRows parentId ops.update+        , upsertTags parentId ops.upsert+        , insertTags parentId ops.create+        , insertTags parentId ops.createMany+        , connectTags parentId ops.connect+        ]+replaceTags :: UUID -> [TagNestedCreate] -> Db (Either ORMError ())+replaceTags parentId items = do+  result <-+    Delete.deleteWhere $+      Delete.whereDelete (fieldColumn tagShelfId <> " = ?") [toField parentId] (Delete.emptyDelete @TagTable)+  case result of+    Left err -> pure (Left err)+    Right _ -> insertTags parentId items+insertTags :: UUID -> [TagNestedCreate] -> Db (Either ORMError ())+insertTags parentId = go+  where+    go [] = pure (Right ())+    go (nested : rest) = do+      result <- case nested of+        ConnectTag key -> connectTags parentId [key]+        CreateTag {id, label} -> do+          inserted <- Insert.insert @TagTable @TagRow TagCreate+            { id = id,+              label = label,+              shelfId = parentId+            }+          pure $ case inserted of+            Left err -> Left err+            Right _ -> Right ()+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+deleteTags :: UUID -> [Tag.TagUnique] -> Db (Either ORMError ())+deleteTags _ [] = pure (Right ())+deleteTags parentId keys = sequenceNested (map deleteOne keys)+  where+    deleteOne key = do+      result <- Delete.deleteMany @TagTable+        (Tag.tagUniqueWhere key `and_` eq tagShelfId parentId)+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()+updateTagsRows :: UUID -> [(Tag.TagUnique, TagUpdate)] -> Db (Either ORMError ())+updateTagsRows parentId = go+  where+    go [] = pure (Right ())+    go ((key, nested) : rest) = do+      let patched = TagUpdate { shelfId = Nothing, label = nested.label }+      result <-+        Update.updateWhere @TagTable @TagRow+          (Tag.tagUniqueWhere key `and_` eq tagShelfId parentId)+          patched+      case result of+        Left err -> pure (Left err)+        Right _ -> go rest+upsertTags :: UUID -> [TagNestedUpsert] -> Db (Either ORMError ())+upsertTags parentId = go+  where+    go [] = pure (Right ())+    go (item : rest) = do+      existing <- Ops.findMany @TagTable @TagRow (matching (Tag.tagUniqueWhere item.where_))+      result <- case fromUniqueRows existing of+        Left err -> pure (Left err)+        Right Nothing -> insertTags parentId [item.create]+        Right (Just row) ->+          if row.shelfId == parentId+            then do+              let patched = TagUpdate { shelfId = Nothing, label = item.update.label }+              updated <-+                Update.updateWhere @TagTable @TagRow+                  (Tag.tagUniqueWhere item.where_ `and_` eq tagShelfId parentId)+                  patched+              pure $ case updated of+                Left err -> Left err+                Right _ -> Right ()+            else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent"))+      case result of+        Left err -> pure (Left err)+        Right () -> go rest+connectTags :: UUID -> [Tag.TagUnique] -> Db (Either ORMError ())+connectTags _ [] = pure (Right ())+connectTags parentId keys = sequenceNested (map connectOne keys)+  where+    connectOne key = do+      result <-+        Update.updateWhere @TagTable @TagRow+          (Tag.tagUniqueWhere key)+          (TagUpdate+            { shelfId = Just parentId,+              label = Nothing+            })+      pure $ case result of+        Left err -> Left err+        Right _ -> Right ()++data ShelfQuery include select = ShelfQuery+  { include_ :: include+  , select_ :: select+  , where_ :: Maybe (Where ShelfTable)+  , orderBy_ :: [OrderBy ShelfTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }++data ShelfUniqueQuery include select = ShelfUniqueQuery+  { include_ :: include+  , select_ :: select+  , where_ :: ShelfUnique+  }++emptyQuery :: ShelfQuery () OmitSelect+emptyQuery =+  ShelfQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}++uniqueQuery :: ShelfUnique -> ShelfUniqueQuery () OmitSelect+uniqueQuery key =+  ShelfUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key}++class ReadShelf include select where+  findMany :: ShelfQuery include select -> Db [ShelfRead include select]+  findUnique :: ShelfUniqueQuery include select -> Db (Either ORMError (Maybe (ShelfRead include select)))+  findUniqueOrFail :: ShelfUniqueQuery include select -> Db (Either ORMError (ShelfRead include select))+  findFirst :: ShelfQuery include select -> Db (Maybe (ShelfRead include select))+  findFirstOrFail :: ShelfQuery include select -> Db (Either ORMError (ShelfRead include select))++instance (LoadShelf books tags) => ReadShelf (ShelfInclude books tags) OmitSelect where+  findMany ShelfQuery {include_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loadShelf include_ roots+  findUnique ShelfUniqueQuery {where_, include_} = do+    let w = shelfUniqueWhere where_+    roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (matching w))+    rows <- loadShelf include_ roots+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ShelfQuery {include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadShelf include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just row+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadShelf () OmitSelect where+  findMany ShelfQuery {where_, orderBy_, limit_, offset_} =+    Ops.findMany @ShelfTable @ShelfRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique ShelfUniqueQuery {where_} = do+    let w = shelfUniqueWhere where_+    rows <- Ops.findMany @ShelfTable @ShelfRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ShelfQuery {where_, orderBy_, limit_, offset_} =+    Ops.findFirst @ShelfTable @ShelfRow (applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance (LoadShelf books tags) => ReadShelf (ShelfInclude books tags) ShelfSelect where+  findMany ShelfQuery {include_, select_, where_, orderBy_, limit_, offset_} = do+    roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ limit_ offset_))+    loaded <- loadShelf include_ roots+    pure $ map (toShelfWithPicked select_) loaded+  findUnique ShelfUniqueQuery {where_, include_, select_} = do+    let w = shelfUniqueWhere where_+    roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (matching w))+    loaded <- loadShelf include_ roots+    let rows = map (toShelfWithPicked select_) loaded+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ShelfQuery {select_, include_, where_, orderBy_, offset_} = do+    roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_))+    loaded <- loadShelf include_ roots+    pure $ case loaded of+      [] -> Nothing+      (row : _) -> Just (toShelfWithPicked select_ row)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadShelf () ShelfSelect where+  findMany ShelfQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findManyWith+      (parseShelfPicked select_)+      (selectColumns (shelfSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findUnique ShelfUniqueQuery {where_, select_} = do+    let w = shelfUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseShelfPicked select_)+        (selectColumns (shelfSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst ShelfQuery {select_, where_, orderBy_, limit_, offset_} =+    Ops.findFirstWith+      (parseShelfPicked select_)+      (selectColumns (shelfSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++count :: ShelfQuery include select -> Db Int+count ShelfQuery {where_, orderBy_, limit_, offset_} =+  Ops.count @ShelfTable (applyQueryModifiers where_ orderBy_ limit_ offset_)++delete :: ShelfUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @ShelfTable (shelfUniqueWhere key)++deleteMany :: Where ShelfTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @ShelfTable
+ test/Schema/Client/Tag.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Schema.Client.Tag+  ( create,+    createMany,+    update,+    updateMany,+    upsert,+    findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    delete,+    deleteMany,+    TagCreate (..),+    TagRow (..),+    TagSelect (..),+    TagPicked (..),+    tagSelect,+    OmitSelect (..),+    Picked (..),+    ResolveSelect,+    TagUpdate (..),+    TagTable,+    TagQuery (..),+    TagUnique (..),+    TagUniqueKey (..),+    TagUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    tagUniqueWhere,+    tagId+  )++where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    QueryBuilder,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    Where,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Tag (TagCreate (..), TagRow (..), TagSelect (..), TagPicked (..), tagSelect, tagSelectColumns, parseTagPicked, TagTable, TagUpdate (..), tagId)++data TagUnique+  = ById UUID+  deriving (Eq, Show)++data TagUniqueKey+  = OnId+  deriving (Eq, Show)++tagUniqueWhere :: TagUnique -> Where TagTable+tagUniqueWhere = \case+  ById v1 -> eq tagId v1++tagConflictCols :: TagUniqueKey -> [Text]+tagConflictCols = \case+  OnId -> ["id"]+++create :: TagCreate -> Db (Either ORMError TagRow)+create = Insert.insert @TagTable @TagRow+++createMany :: [TagCreate] -> Db (Either ORMError Int)+createMany = Insert.insertMany @TagTable+++update :: TagUnique -> TagUpdate -> Db (Either ORMError TagRow)+update key input =+  Update.updateWhere @TagTable @TagRow (tagUniqueWhere key) input+++updateMany :: Where TagTable -> TagUpdate -> Db (Either ORMError Int)+updateMany = Update.updateMany @TagTable+++upsert :: TagUniqueKey -> TagCreate -> TagUpdate -> Db (Either ORMError TagRow)+upsert key createInput updateInput =+  Insert.upsert @TagTable @TagRow (tagConflictCols key) createInput updateInput+++data TagQuery select = TagQuery+  { select_ :: select+  , where_ :: Maybe (Where TagTable)+  , orderBy_ :: [OrderBy TagTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }+++data TagUniqueQuery select = TagUniqueQuery+  { select_ :: select+  , where_ :: TagUnique+  }+++emptyQuery :: TagQuery OmitSelect+emptyQuery =+  TagQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}+++uniqueQuery :: TagUnique -> TagUniqueQuery OmitSelect+uniqueQuery key =+  TagUniqueQuery {select_ = OmitSelect, where_ = key}+++type family ResolveSelect select+type instance ResolveSelect OmitSelect = TagRow+type instance ResolveSelect TagSelect = TagPicked+++class ReadTag select where+  findMany :: TagQuery select -> Db [ResolveSelect select]+  findUnique :: TagUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select)))+  findUniqueOrFail :: TagUniqueQuery select -> Db (Either ORMError (ResolveSelect select))+  findFirst :: TagQuery select -> Db (Maybe (ResolveSelect select))+  findFirstOrFail :: TagQuery select -> Db (Either ORMError (ResolveSelect select))++instance ReadTag OmitSelect where+  findMany q =+    Ops.findMany @TagTable @TagRow (applyQuery q)+  findUnique TagUniqueQuery {where_} = do+    let w = tagUniqueWhere where_+    rows <- Ops.findMany @TagTable @TagRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q =+    Ops.findFirst @TagTable @TagRow (applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadTag TagSelect where+  findMany q@TagQuery {select_} =+    Ops.findManyWith+      (parseTagPicked select_)+      (selectColumns (tagSelectColumns select_) . applyQuery q)+  findUnique TagUniqueQuery {where_, select_} = do+    let w = tagUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseTagPicked select_)+        (selectColumns (tagSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q@TagQuery {select_} =+    Ops.findFirstWith+      (parseTagPicked select_)+      (selectColumns (tagSelectColumns select_) . applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++applyQuery :: TagQuery select -> QueryBuilder TagTable -> QueryBuilder TagTable+applyQuery TagQuery {where_, orderBy_, limit_, offset_} =+  applyQueryModifiers where_ orderBy_ limit_ offset_+++count :: TagQuery select -> Db Int+count q = Ops.count @TagTable (applyQuery q)+++delete :: TagUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @TagTable (tagUniqueWhere key)+++deleteMany :: Where TagTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @TagTable+
+ test/Schema/Client/Widget.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Schema.Client.Widget+  ( create,+    createMany,+    update,+    updateMany,+    upsert,+    findMany,+    findUnique,+    findUniqueOrFail,+    findFirst,+    findFirstOrFail,+    count,+    delete,+    deleteMany,+    WidgetCreate (..),+    WidgetRow (..),+    WidgetSelect (..),+    WidgetPicked (..),+    widgetSelect,+    OmitSelect (..),+    Picked (..),+    ResolveSelect,+    WidgetUpdate (..),+    WidgetTable,+    WidgetQuery (..),+    WidgetUnique (..),+    WidgetUniqueKey (..),+    WidgetUniqueQuery (..),+    emptyQuery,+    uniqueQuery,+    widgetUniqueWhere,+    widgetId+  )++where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( Db,+    ORMError (..),+    fromUniqueRows,+    requireFound,+    uniqueOrFail,+    OrderBy,+    QueryBuilder,+    applyQueryModifiers,+    matching,+    selectColumns,+    OmitSelect (..),+    Picked (..),+    Where,+    eq+  )+import qualified Poppy.Internal.Generated as Delete+  ( deleteMany+  )+import qualified Poppy.Internal.Generated as Insert+  ( insert,+    insertMany,+    upsert+  )+import qualified Poppy.Internal.Generated as Ops+  ( findMany,+    findManyWith,+    findFirst,+    findFirstWith,+    count+  )+import qualified Poppy.Internal.Generated as Update+  ( updateWhere,+    updateMany+  )++import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetSelect (..), WidgetPicked (..), widgetSelect, widgetSelectColumns, parseWidgetPicked, WidgetTable, WidgetUpdate (..), widgetId, widgetName)++data WidgetUnique+  = ById UUID+  | ByName Text+  deriving (Eq, Show)++data WidgetUniqueKey+  = OnId+  | OnName+  deriving (Eq, Show)++widgetUniqueWhere :: WidgetUnique -> Where WidgetTable+widgetUniqueWhere = \case+  ById v1 -> eq widgetId v1+  ByName v1 -> eq widgetName v1++widgetConflictCols :: WidgetUniqueKey -> [Text]+widgetConflictCols = \case+  OnId -> ["id"]+  OnName -> ["name"]+++create :: WidgetCreate -> Db (Either ORMError WidgetRow)+create = Insert.insert @WidgetTable @WidgetRow+++createMany :: [WidgetCreate] -> Db (Either ORMError Int)+createMany = Insert.insertMany @WidgetTable+++update :: WidgetUnique -> WidgetUpdate -> Db (Either ORMError WidgetRow)+update key input =+  Update.updateWhere @WidgetTable @WidgetRow (widgetUniqueWhere key) input+++updateMany :: Where WidgetTable -> WidgetUpdate -> Db (Either ORMError Int)+updateMany = Update.updateMany @WidgetTable+++upsert :: WidgetUniqueKey -> WidgetCreate -> WidgetUpdate -> Db (Either ORMError WidgetRow)+upsert key createInput updateInput =+  Insert.upsert @WidgetTable @WidgetRow (widgetConflictCols key) createInput updateInput+++data WidgetQuery select = WidgetQuery+  { select_ :: select+  , where_ :: Maybe (Where WidgetTable)+  , orderBy_ :: [OrderBy WidgetTable]+  , limit_ :: Maybe Int+  , offset_ :: Maybe Int+  }+++data WidgetUniqueQuery select = WidgetUniqueQuery+  { select_ :: select+  , where_ :: WidgetUnique+  }+++emptyQuery :: WidgetQuery OmitSelect+emptyQuery =+  WidgetQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}+++uniqueQuery :: WidgetUnique -> WidgetUniqueQuery OmitSelect+uniqueQuery key =+  WidgetUniqueQuery {select_ = OmitSelect, where_ = key}+++type family ResolveSelect select+type instance ResolveSelect OmitSelect = WidgetRow+type instance ResolveSelect WidgetSelect = WidgetPicked+++class ReadWidget select where+  findMany :: WidgetQuery select -> Db [ResolveSelect select]+  findUnique :: WidgetUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select)))+  findUniqueOrFail :: WidgetUniqueQuery select -> Db (Either ORMError (ResolveSelect select))+  findFirst :: WidgetQuery select -> Db (Maybe (ResolveSelect select))+  findFirstOrFail :: WidgetQuery select -> Db (Either ORMError (ResolveSelect select))++instance ReadWidget OmitSelect where+  findMany q =+    Ops.findMany @WidgetTable @WidgetRow (applyQuery q)+  findUnique WidgetUniqueQuery {where_} = do+    let w = widgetUniqueWhere where_+    rows <- Ops.findMany @WidgetTable @WidgetRow (matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q =+    Ops.findFirst @WidgetTable @WidgetRow (applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++instance ReadWidget WidgetSelect where+  findMany q@WidgetQuery {select_} =+    Ops.findManyWith+      (parseWidgetPicked select_)+      (selectColumns (widgetSelectColumns select_) . applyQuery q)+  findUnique WidgetUniqueQuery {where_, select_} = do+    let w = widgetUniqueWhere where_+    rows <-+      Ops.findManyWith+        (parseWidgetPicked select_)+        (selectColumns (widgetSelectColumns select_) . matching w)+    pure (fromUniqueRows rows)+  findUniqueOrFail q = uniqueOrFail <$> findUnique q+  findFirst q@WidgetQuery {select_} =+    Ops.findFirstWith+      (parseWidgetPicked select_)+      (selectColumns (widgetSelectColumns select_) . applyQuery q)+  findFirstOrFail q = do+    result <- findFirst q+    pure $ requireFound result (RecordNotFound "No record found matching query")++applyQuery :: WidgetQuery select -> QueryBuilder WidgetTable -> QueryBuilder WidgetTable+applyQuery WidgetQuery {where_, orderBy_, limit_, offset_} =+  applyQueryModifiers where_ orderBy_ limit_ offset_+++count :: WidgetQuery select -> Db Int+count q = Ops.count @WidgetTable (applyQuery q)+++delete :: WidgetUnique -> Db (Either ORMError Int)+delete key =+  Delete.deleteMany @WidgetTable (widgetUniqueWhere key)+++deleteMany :: Where WidgetTable -> Db (Either ORMError Int)+deleteMany = Delete.deleteMany @WidgetTable+
+ test/Schema/Comment.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Comment+  ( CommentTable (..),+    CommentRow (..),+    CommentSelect (..),+    CommentPicked (..),+    commentSelect,+    commentSelectColumns,+    parseCommentPicked,+    toCommentPicked,+    CommentCreate (..),+    CommentUpdate (..),+    commentId,+    commentParentId,+    commentBody+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    NullableValue (..),+    set,+    setMaybe,+    setNullable,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe,+    setFieldNullable+  )++data CommentTable = CommentTable++type instance PrimaryKeyType CommentTable = UUID++type instance ModelTable "Comment" = CommentTable++instance Entity CommentTable where+  tableName = "test_comment"+  primaryKey = commentId+  tableColumns = ["id", "parent_id", "body"]++instance Insertable CommentTable where+  type CreateInput CommentTable = CommentCreate+  toInsertBuilder input =+    setMaybe commentId input.id $+      setNullable commentParentId input.parentId $+      set commentBody input.body $+      emptyInsert @CommentTable+++instance Updatable CommentTable where+  type UpdateInput CommentTable = CommentUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldNullable commentParentId input.parentId $+      setFieldMaybe commentBody input.body $+      emptyUpdate @CommentTable+++data CommentRow = CommentRow+  { id :: UUID,+    parentId :: Maybe UUID,+    body :: Text+  }+  deriving (Show, Eq)+++data CommentCreate = CommentCreate+  { id :: Maybe UUID,+    parentId :: NullableValue UUID,+    body :: Text+  }+  deriving (Show, Eq)+++data CommentUpdate = CommentUpdate+  { parentId :: NullableValue UUID,+    body :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow CommentRow where+  fromRow = CommentRow <$> field <*> field <*> field+++data CommentSelect = CommentSelect+  { id :: Bool,+    parentId :: Bool,+    body :: Bool+  }+  deriving (Show, Eq)+data CommentPicked = CommentPicked+  { id :: UUID,+    parentId :: Picked (Maybe UUID),+    body :: Picked Text+  }+  deriving (Show, Eq)+commentSelect :: CommentSelect+commentSelect =+  CommentSelect+    { id = False,+      parentId = False,+      body = False+    }+commentSelectColumns :: CommentSelect -> [Text]+commentSelectColumns select_ =+  fieldColumn commentId+    : concat+      [ [fieldColumn commentParentId | select_.parentId]+      , [fieldColumn commentBody | select_.body]+      ]+parseCommentPicked :: CommentSelect -> RowParser CommentPicked+parseCommentPicked select_ = do+  idVal <- field+  parentIdVal <- if select_.parentId then Picked <$> field else pure Skipped+  bodyVal <- if select_.body then Picked <$> field else pure Skipped+  pure CommentPicked { id = idVal, parentId = parentIdVal, body = bodyVal }+toCommentPicked :: CommentSelect -> CommentRow -> CommentPicked+toCommentPicked select_ row =+  CommentPicked+    { id = row.id,+      parentId = picked select_.parentId row.parentId,+      body = picked select_.body row.body+    }+++commentId :: Field CommentTable UUID+commentId = Field "id" "id"++commentParentId :: Field CommentTable UUID+commentParentId = Field "parentId" "parent_id"++commentBody :: Field CommentTable Text+commentBody = Field "body" "body"+
+ test/Schema/Editor.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Editor+  ( EditorTable (..),+    EditorRow (..),+    EditorSelect (..),+    EditorPicked (..),+    editorSelect,+    editorSelectColumns,+    parseEditorPicked,+    toEditorPicked,+    EditorCreate (..),+    EditorUpdate (..),+    editorId,+    editorName+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data EditorTable = EditorTable++type instance PrimaryKeyType EditorTable = UUID++type instance ModelTable "Editor" = EditorTable++instance Entity EditorTable where+  tableName = "test_editor"+  primaryKey = editorId+  tableColumns = ["id", "name"]++instance Insertable EditorTable where+  type CreateInput EditorTable = EditorCreate+  toInsertBuilder input =+    setMaybe editorId input.id $+      set editorName input.name $+      emptyInsert @EditorTable+++instance Updatable EditorTable where+  type UpdateInput EditorTable = EditorUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe editorName input.name $+      emptyUpdate @EditorTable+++data EditorRow = EditorRow+  { id :: UUID,+    name :: Text+  }+  deriving (Show, Eq)+++data EditorCreate = EditorCreate+  { id :: Maybe UUID,+    name :: Text+  }+  deriving (Show, Eq)+++data EditorUpdate = EditorUpdate+  { name :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow EditorRow where+  fromRow = EditorRow <$> field <*> field+++data EditorSelect = EditorSelect+  { id :: Bool,+    name :: Bool+  }+  deriving (Show, Eq)+data EditorPicked = EditorPicked+  { id :: UUID,+    name :: Picked Text+  }+  deriving (Show, Eq)+editorSelect :: EditorSelect+editorSelect =+  EditorSelect+    { id = False,+      name = False+    }+editorSelectColumns :: EditorSelect -> [Text]+editorSelectColumns select_ =+  fieldColumn editorId+    : concat+      [ [fieldColumn editorName | select_.name]+      ]+parseEditorPicked :: EditorSelect -> RowParser EditorPicked+parseEditorPicked select_ = do+  idVal <- field+  nameVal <- if select_.name then Picked <$> field else pure Skipped+  pure EditorPicked { id = idVal, name = nameVal }+toEditorPicked :: EditorSelect -> EditorRow -> EditorPicked+toEditorPicked select_ row =+  EditorPicked+    { id = row.id,+      name = picked select_.name row.name+    }+++editorId :: Field EditorTable UUID+editorId = Field "id" "id"++editorName :: Field EditorTable Text+editorName = Field "name" "name"+
+ test/Schema/Include/Author.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema.Include.Author+  ( AuthorInclude (..)+  , AuthorWith (..)+  , AuthorWithPicked (..)+  , AuthorPosts+  , AuthorResult+  , AuthorRead+  , LoadAuthor (..)+  , toAuthorWithPicked+  , PostInclude (..)+  , PostWith (..)+  , PostWithPicked (..)+  , PostAuthor+  , PostResult+  , PostRead+  , LoadPost (..)+  , toPostWithPicked+  )+where++import Poppy.Internal.Generated+  ( Db,+    IncludeFor,+    Load (..),+    Skip (..),+    Skipped,+    ValidEdge,+    skipped,+    OmitSelect (..),+    requireRelated,+    findByIn,+    indexByPk,+    indexHasMany,+    lookupByPk,+    lookupGroups+  )+import qualified Schema.Author as Author+import Schema.Author (AuthorPicked, AuthorRow (..), AuthorSelect, AuthorTable, toAuthorPicked)+import qualified Schema.Post as Post+import Schema.Post (PostPicked, PostRow (..), PostSelect, PostTable, toPostPicked)++data AuthorInclude posts = AuthorInclude+  { posts :: posts+  }+  deriving (Show, Eq)++data AuthorWith posts = AuthorWith+  { author :: AuthorRow,+    posts :: AuthorPosts posts+  }++deriving instance (Eq AuthorRow, Eq (AuthorPosts posts)) => Eq (AuthorWith posts)+deriving instance (Show AuthorRow, Show (AuthorPosts posts)) => Show (AuthorWith posts)++data AuthorWithPicked posts = AuthorWithPicked+  { author :: AuthorPicked,+    posts :: AuthorPosts posts+  }++deriving instance (Eq AuthorPicked, Eq (AuthorPosts posts)) => Eq (AuthorWithPicked posts)+deriving instance (Show AuthorPicked, Show (AuthorPosts posts)) => Show (AuthorWithPicked posts)++toAuthorWithPicked :: AuthorSelect -> AuthorWith posts -> AuthorWithPicked posts+toAuthorWithPicked select_ nested =+  AuthorWithPicked+    { author = toAuthorPicked select_ nested.author,+      posts = nested.posts+    }++type family AuthorPosts edge where+  AuthorPosts Skip = Skipped "posts" [PostRow]+  AuthorPosts (Load PostTable include) = [PostResult include]++type family AuthorResult include where+  AuthorResult () = AuthorRow+  AuthorResult (AuthorInclude posts) = AuthorWith posts++type family AuthorRead include select where+  AuthorRead () OmitSelect = AuthorRow+  AuthorRead () AuthorSelect = AuthorPicked+  AuthorRead (AuthorInclude posts) OmitSelect = AuthorWith posts+  AuthorRead (AuthorInclude posts) AuthorSelect = AuthorWithPicked posts++data PostInclude author = PostInclude+  { author :: author+  }+  deriving (Show, Eq)++data PostWith author = PostWith+  { post :: PostRow,+    author :: PostAuthor author+  }++deriving instance (Eq PostRow, Eq (PostAuthor author)) => Eq (PostWith author)+deriving instance (Show PostRow, Show (PostAuthor author)) => Show (PostWith author)++data PostWithPicked author = PostWithPicked+  { post :: PostPicked,+    author :: PostAuthor author+  }++deriving instance (Eq PostPicked, Eq (PostAuthor author)) => Eq (PostWithPicked author)+deriving instance (Show PostPicked, Show (PostAuthor author)) => Show (PostWithPicked author)++toPostWithPicked :: PostSelect -> PostWith author -> PostWithPicked author+toPostWithPicked select_ nested =+  PostWithPicked+    { post = toPostPicked select_ nested.post,+      author = nested.author+    }++type family PostAuthor edge where+  PostAuthor Skip = Skipped "author" AuthorRow+  PostAuthor (Load AuthorTable include) = AuthorResult include++type family PostResult include where+  PostResult () = PostRow+  PostResult (PostInclude author) = PostWith author++type family PostRead include select where+  PostRead () OmitSelect = PostRow+  PostRead () PostSelect = PostPicked+  PostRead (PostInclude author) OmitSelect = PostWith author+  PostRead (PostInclude author) PostSelect = PostWithPicked author++class LoadAuthorPosts edge where+  loadAuthorPosts :: edge -> [AuthorRow] -> Db [AuthorPosts edge]++instance LoadAuthorPosts Skip where+  loadAuthorPosts Skip roots = pure (map (const skipped) roots)++instance LoadAuthorPosts (Load PostTable ()) where+  loadAuthorPosts edge roots = do+    rows <- findByIn @PostTable @PostRow Post.postAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.authorId) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance (LoadPost author) => LoadAuthorPosts (Load PostTable (PostInclude author)) where+  loadAuthorPosts edge roots = do+    rows <- findByIn @PostTable @PostRow Post.postAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    loaded <- loadPost edge.include_ rows+    let grouped = indexHasMany ((.authorId) . (.post)) loaded+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Post" edge) => LoadAuthorPosts edge where+  loadAuthorPosts _ roots = pure (map (const skipped) roots)++class LoadAuthor posts where+  loadAuthor :: AuthorInclude posts -> [AuthorRow] -> Db [AuthorWith posts]++instance (LoadAuthorPosts posts, ValidEdge "Post" posts) => LoadAuthor posts where+  loadAuthor include roots = do+    postsLoaded <- loadAuthorPosts include.posts roots+    pure+      [ AuthorWith+          { author = root,+            posts = postsLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Post" posts) => IncludeFor "Author" (AuthorInclude posts)++class LoadPostAuthor edge where+  loadPostAuthor :: edge -> [PostRow] -> Db [PostAuthor edge]++instance LoadPostAuthor Skip where+  loadPostAuthor Skip roots = pure (map (const skipped) roots)++instance LoadPostAuthor (Load AuthorTable ()) where+  loadPostAuthor edge roots = do+    rows <- findByIn @AuthorTable @AuthorRow Author.authorId (map (.authorId) roots) edge.where_ edge.orderBy_ edge.take_+    let indexed = indexByPk (.id) rows+    pure [requireRelated "author" (lookupByPk root.authorId indexed) | root <- roots]++instance (LoadAuthor posts) => LoadPostAuthor (Load AuthorTable (AuthorInclude posts)) where+  loadPostAuthor edge roots = do+    rows <- findByIn @AuthorTable @AuthorRow Author.authorId (map (.authorId) roots) edge.where_ edge.orderBy_ edge.take_+    loaded <- loadAuthor edge.include_ rows+    let indexed = indexByPk ((.id) . (.author)) loaded+    pure [requireRelated "author" (lookupByPk root.authorId indexed) | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Author" edge) => LoadPostAuthor edge where+  loadPostAuthor _ roots = pure (map (const skipped) roots)++class LoadPost author where+  loadPost :: PostInclude author -> [PostRow] -> Db [PostWith author]++instance (LoadPostAuthor author, ValidEdge "Author" author) => LoadPost author where+  loadPost include roots = do+    authorLoaded <- loadPostAuthor include.author roots+    pure+      [ PostWith+          { post = root,+            author = authorLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Author" author) => IncludeFor "Post" (PostInclude author)+
+ test/Schema/Include/Book.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema.Include.Book+  ( BookInclude (..)+  , BookWith (..)+  , BookWithPicked (..)+  , BookChapters+  , BookResult+  , BookRead+  , LoadBook (..)+  , toBookWithPicked+  )+where++import Poppy.Internal.Generated+  ( Db,+    IncludeFor,+    Load (..),+    Skip (..),+    Skipped,+    ValidEdge,+    skipped,+    OmitSelect (..),+    findByIn,+    indexHasMany,+    lookupGroups+  )+import Schema.Book (BookPicked, BookRow (..), BookSelect, toBookPicked)+import qualified Schema.Chapter as Chapter+import Schema.Chapter (ChapterRow (..), ChapterTable)+import Schema.Include.Chapter (ChapterInclude (..), ChapterResult, ChapterWith (..), LoadChapter (..))++data BookInclude chapters = BookInclude+  { chapters :: chapters+  }+  deriving (Show, Eq)++data BookWith chapters = BookWith+  { book :: BookRow,+    chapters :: BookChapters chapters+  }++deriving instance (Eq BookRow, Eq (BookChapters chapters)) => Eq (BookWith chapters)+deriving instance (Show BookRow, Show (BookChapters chapters)) => Show (BookWith chapters)++data BookWithPicked chapters = BookWithPicked+  { book :: BookPicked,+    chapters :: BookChapters chapters+  }++deriving instance (Eq BookPicked, Eq (BookChapters chapters)) => Eq (BookWithPicked chapters)+deriving instance (Show BookPicked, Show (BookChapters chapters)) => Show (BookWithPicked chapters)++toBookWithPicked :: BookSelect -> BookWith chapters -> BookWithPicked chapters+toBookWithPicked select_ nested =+  BookWithPicked+    { book = toBookPicked select_ nested.book,+      chapters = nested.chapters+    }++type family BookChapters edge where+  BookChapters Skip = Skipped "chapters" [ChapterRow]+  BookChapters (Load ChapterTable include) = [ChapterResult include]++type family BookResult include where+  BookResult () = BookRow+  BookResult (BookInclude chapters) = BookWith chapters++type family BookRead include select where+  BookRead () OmitSelect = BookRow+  BookRead () BookSelect = BookPicked+  BookRead (BookInclude chapters) OmitSelect = BookWith chapters+  BookRead (BookInclude chapters) BookSelect = BookWithPicked chapters++class LoadBookChapters edge where+  loadBookChapters :: edge -> [BookRow] -> Db [BookChapters edge]++instance LoadBookChapters Skip where+  loadBookChapters Skip roots = pure (map (const skipped) roots)++instance LoadBookChapters (Load ChapterTable ()) where+  loadBookChapters edge roots = do+    rows <- findByIn @ChapterTable @ChapterRow Chapter.chapterBookRef (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.bookRef) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance (LoadChapter sections) => LoadBookChapters (Load ChapterTable (ChapterInclude sections)) where+  loadBookChapters edge roots = do+    rows <- findByIn @ChapterTable @ChapterRow Chapter.chapterBookRef (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    loaded <- loadChapter edge.include_ rows+    let grouped = indexHasMany ((.bookRef) . (.chapter)) loaded+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Chapter" edge) => LoadBookChapters edge where+  loadBookChapters _ roots = pure (map (const skipped) roots)++class LoadBook chapters where+  loadBook :: BookInclude chapters -> [BookRow] -> Db [BookWith chapters]++instance (LoadBookChapters chapters, ValidEdge "Chapter" chapters) => LoadBook chapters where+  loadBook include roots = do+    chaptersLoaded <- loadBookChapters include.chapters roots+    pure+      [ BookWith+          { book = root,+            chapters = chaptersLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Chapter" chapters) => IncludeFor "Book" (BookInclude chapters)+
+ test/Schema/Include/Chapter.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema.Include.Chapter+  ( ChapterInclude (..)+  , ChapterWith (..)+  , ChapterWithPicked (..)+  , ChapterSections+  , ChapterResult+  , ChapterRead+  , LoadChapter (..)+  , toChapterWithPicked+  )+where++import Poppy.Internal.Generated+  ( Db,+    IncludeFor,+    Load (..),+    Skip (..),+    Skipped,+    ValidEdge,+    skipped,+    OmitSelect (..),+    findByIn,+    indexHasMany,+    lookupGroups+  )+import Schema.Chapter (ChapterPicked, ChapterRow (..), ChapterSelect, toChapterPicked)+import qualified Schema.Section as Section+import Schema.Section (SectionRow (..), SectionTable)++data ChapterInclude sections = ChapterInclude+  { sections :: sections+  }+  deriving (Show, Eq)++data ChapterWith sections = ChapterWith+  { chapter :: ChapterRow,+    sections :: ChapterSections sections+  }++deriving instance (Eq ChapterRow, Eq (ChapterSections sections)) => Eq (ChapterWith sections)+deriving instance (Show ChapterRow, Show (ChapterSections sections)) => Show (ChapterWith sections)++data ChapterWithPicked sections = ChapterWithPicked+  { chapter :: ChapterPicked,+    sections :: ChapterSections sections+  }++deriving instance (Eq ChapterPicked, Eq (ChapterSections sections)) => Eq (ChapterWithPicked sections)+deriving instance (Show ChapterPicked, Show (ChapterSections sections)) => Show (ChapterWithPicked sections)++toChapterWithPicked :: ChapterSelect -> ChapterWith sections -> ChapterWithPicked sections+toChapterWithPicked select_ nested =+  ChapterWithPicked+    { chapter = toChapterPicked select_ nested.chapter,+      sections = nested.sections+    }++type family ChapterSections edge where+  ChapterSections Skip = Skipped "sections" [SectionRow]+  ChapterSections (Load SectionTable ()) = [SectionRow]++type family ChapterResult include where+  ChapterResult () = ChapterRow+  ChapterResult (ChapterInclude sections) = ChapterWith sections++type family ChapterRead include select where+  ChapterRead () OmitSelect = ChapterRow+  ChapterRead () ChapterSelect = ChapterPicked+  ChapterRead (ChapterInclude sections) OmitSelect = ChapterWith sections+  ChapterRead (ChapterInclude sections) ChapterSelect = ChapterWithPicked sections++class LoadChapterSections edge where+  loadChapterSections :: edge -> [ChapterRow] -> Db [ChapterSections edge]++instance LoadChapterSections Skip where+  loadChapterSections Skip roots = pure (map (const skipped) roots)++instance LoadChapterSections (Load SectionTable ()) where+  loadChapterSections edge roots = do+    rows <- findByIn @SectionTable @SectionRow Section.sectionChapterRef (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.chapterRef) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Section" edge) => LoadChapterSections edge where+  loadChapterSections _ roots = pure (map (const skipped) roots)++class LoadChapter sections where+  loadChapter :: ChapterInclude sections -> [ChapterRow] -> Db [ChapterWith sections]++instance (LoadChapterSections sections, ValidEdge "Section" sections) => LoadChapter sections where+  loadChapter include roots = do+    sectionsLoaded <- loadChapterSections include.sections roots+    pure+      [ ChapterWith+          { chapter = root,+            sections = sectionsLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Section" sections) => IncludeFor "Chapter" (ChapterInclude sections)+
+ test/Schema/Include/Comment.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema.Include.Comment+  ( CommentInclude (..)+  , CommentWith (..)+  , CommentWithPicked (..)+  , CommentReplies+  , CommentResult+  , CommentRead+  , LoadComment (..)+  , toCommentWithPicked+  )+where++import Poppy.Internal.Generated+  ( Db,+    IncludeFor,+    Load (..),+    Skip (..),+    Skipped,+    ValidEdge,+    skipped,+    OmitSelect (..),+    findByIn,+    indexHasManyMaybe,+    lookupGroups+  )+import qualified Schema.Comment as Comment+import Schema.Comment (CommentPicked, CommentRow (..), CommentSelect, CommentTable, toCommentPicked)++data CommentInclude replies = CommentInclude+  { replies :: replies+  }+  deriving (Show, Eq)++data CommentWith replies = CommentWith+  { comment :: CommentRow,+    replies :: CommentReplies replies+  }++deriving instance (Eq CommentRow, Eq (CommentReplies replies)) => Eq (CommentWith replies)+deriving instance (Show CommentRow, Show (CommentReplies replies)) => Show (CommentWith replies)++data CommentWithPicked replies = CommentWithPicked+  { comment :: CommentPicked,+    replies :: CommentReplies replies+  }++deriving instance (Eq CommentPicked, Eq (CommentReplies replies)) => Eq (CommentWithPicked replies)+deriving instance (Show CommentPicked, Show (CommentReplies replies)) => Show (CommentWithPicked replies)++toCommentWithPicked :: CommentSelect -> CommentWith replies -> CommentWithPicked replies+toCommentWithPicked select_ nested =+  CommentWithPicked+    { comment = toCommentPicked select_ nested.comment,+      replies = nested.replies+    }++type family CommentReplies edge where+  CommentReplies Skip = Skipped "replies" [CommentRow]+  CommentReplies (Load CommentTable include) = [CommentResult include]++type family CommentResult include where+  CommentResult () = CommentRow+  CommentResult (CommentInclude replies) = CommentWith replies++type family CommentRead include select where+  CommentRead () OmitSelect = CommentRow+  CommentRead () CommentSelect = CommentPicked+  CommentRead (CommentInclude replies) OmitSelect = CommentWith replies+  CommentRead (CommentInclude replies) CommentSelect = CommentWithPicked replies++class LoadCommentReplies edge where+  loadCommentReplies :: edge -> [CommentRow] -> Db [CommentReplies edge]++instance LoadCommentReplies Skip where+  loadCommentReplies Skip roots = pure (map (const skipped) roots)++instance LoadCommentReplies (Load CommentTable ()) where+  loadCommentReplies edge roots = do+    rows <- findByIn @CommentTable @CommentRow Comment.commentParentId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasManyMaybe (.parentId) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance (LoadComment replies) => LoadCommentReplies (Load CommentTable (CommentInclude replies)) where+  loadCommentReplies edge roots = do+    rows <- findByIn @CommentTable @CommentRow Comment.commentParentId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    loaded <- loadComment edge.include_ rows+    let grouped = indexHasManyMaybe ((.parentId) . (.comment)) loaded+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Comment" edge) => LoadCommentReplies edge where+  loadCommentReplies _ roots = pure (map (const skipped) roots)++class LoadComment replies where+  loadComment :: CommentInclude replies -> [CommentRow] -> Db [CommentWith replies]++instance (LoadCommentReplies replies, ValidEdge "Comment" replies) => LoadComment replies where+  loadComment include roots = do+    repliesLoaded <- loadCommentReplies include.replies roots+    pure+      [ CommentWith+          { comment = root,+            replies = repliesLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Comment" replies) => IncludeFor "Comment" (CommentInclude replies)+
+ test/Schema/Include/Editor.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema.Include.Editor+  ( EditorInclude (..)+  , EditorWith (..)+  , EditorWithPicked (..)+  , EditorWrittenPosts+  , EditorEditedPosts+  , EditorResult+  , EditorRead+  , LoadEditor (..)+  , toEditorWithPicked+  )+where++import Poppy.Internal.Generated+  ( Db,+    IncludeFor,+    Load (..),+    Skip (..),+    Skipped,+    ValidEdge,+    skipped,+    OmitSelect (..),+    findByIn,+    indexHasMany,+    lookupGroups+  )+import Schema.Editor (EditorPicked, EditorRow (..), EditorSelect, toEditorPicked)+import qualified Schema.Article as Article+import Schema.Article (ArticleRow (..), ArticleTable)++data EditorInclude writtenPosts editedPosts = EditorInclude+  { writtenPosts :: writtenPosts,+    editedPosts :: editedPosts+  }+  deriving (Show, Eq)++data EditorWith writtenPosts editedPosts = EditorWith+  { editor :: EditorRow,+    writtenPosts :: EditorWrittenPosts writtenPosts,+    editedPosts :: EditorEditedPosts editedPosts+  }++deriving instance (Eq EditorRow, Eq (EditorWrittenPosts writtenPosts), Eq (EditorEditedPosts editedPosts)) => Eq (EditorWith writtenPosts editedPosts)+deriving instance (Show EditorRow, Show (EditorWrittenPosts writtenPosts), Show (EditorEditedPosts editedPosts)) => Show (EditorWith writtenPosts editedPosts)++data EditorWithPicked writtenPosts editedPosts = EditorWithPicked+  { editor :: EditorPicked,+    writtenPosts :: EditorWrittenPosts writtenPosts,+    editedPosts :: EditorEditedPosts editedPosts+  }++deriving instance (Eq EditorPicked, Eq (EditorWrittenPosts writtenPosts), Eq (EditorEditedPosts editedPosts)) => Eq (EditorWithPicked writtenPosts editedPosts)+deriving instance (Show EditorPicked, Show (EditorWrittenPosts writtenPosts), Show (EditorEditedPosts editedPosts)) => Show (EditorWithPicked writtenPosts editedPosts)++toEditorWithPicked :: EditorSelect -> EditorWith writtenPosts editedPosts -> EditorWithPicked writtenPosts editedPosts+toEditorWithPicked select_ nested =+  EditorWithPicked+    { editor = toEditorPicked select_ nested.editor,+      writtenPosts = nested.writtenPosts,+      editedPosts = nested.editedPosts+    }++type family EditorWrittenPosts edge where+  EditorWrittenPosts Skip = Skipped "writtenPosts" [ArticleRow]+  EditorWrittenPosts (Load ArticleTable ()) = [ArticleRow]++type family EditorEditedPosts edge where+  EditorEditedPosts Skip = Skipped "editedPosts" [ArticleRow]+  EditorEditedPosts (Load ArticleTable ()) = [ArticleRow]++type family EditorResult include where+  EditorResult () = EditorRow+  EditorResult (EditorInclude writtenPosts editedPosts) = EditorWith writtenPosts editedPosts++type family EditorRead include select where+  EditorRead () OmitSelect = EditorRow+  EditorRead () EditorSelect = EditorPicked+  EditorRead (EditorInclude writtenPosts editedPosts) OmitSelect = EditorWith writtenPosts editedPosts+  EditorRead (EditorInclude writtenPosts editedPosts) EditorSelect = EditorWithPicked writtenPosts editedPosts++class LoadEditorWrittenPosts edge where+  loadEditorWrittenPosts :: edge -> [EditorRow] -> Db [EditorWrittenPosts edge]++instance LoadEditorWrittenPosts Skip where+  loadEditorWrittenPosts Skip roots = pure (map (const skipped) roots)++instance LoadEditorWrittenPosts (Load ArticleTable ()) where+  loadEditorWrittenPosts edge roots = do+    rows <- findByIn @ArticleTable @ArticleRow Article.articleAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.authorId) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Article" edge) => LoadEditorWrittenPosts edge where+  loadEditorWrittenPosts _ roots = pure (map (const skipped) roots)++class LoadEditorEditedPosts edge where+  loadEditorEditedPosts :: edge -> [EditorRow] -> Db [EditorEditedPosts edge]++instance LoadEditorEditedPosts Skip where+  loadEditorEditedPosts Skip roots = pure (map (const skipped) roots)++instance LoadEditorEditedPosts (Load ArticleTable ()) where+  loadEditorEditedPosts edge roots = do+    rows <- findByIn @ArticleTable @ArticleRow Article.articleAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.authorId) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Article" edge) => LoadEditorEditedPosts edge where+  loadEditorEditedPosts _ roots = pure (map (const skipped) roots)++class LoadEditor writtenPosts editedPosts where+  loadEditor :: EditorInclude writtenPosts editedPosts -> [EditorRow] -> Db [EditorWith writtenPosts editedPosts]++instance (LoadEditorWrittenPosts writtenPosts, LoadEditorEditedPosts editedPosts, ValidEdge "Article" writtenPosts, ValidEdge "Article" editedPosts) => LoadEditor writtenPosts editedPosts where+  loadEditor include roots = do+    writtenPostsLoaded <- loadEditorWrittenPosts include.writtenPosts roots+    editedPostsLoaded <- loadEditorEditedPosts include.editedPosts roots+    pure+      [ EditorWith+          { editor = root,+            writtenPosts = writtenPostsLoaded !! n,+            editedPosts = editedPostsLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Article" writtenPosts, ValidEdge "Article" editedPosts) => IncludeFor "Editor" (EditorInclude writtenPosts editedPosts)+
+ test/Schema/Include/Post.hs view
@@ -0,0 +1,13 @@+module Schema.Include.Post+  ( PostInclude (..)+  , PostWith (..)+  , PostWithPicked (..)+  , PostAuthor+  , PostResult+  , PostRead+  , LoadPost (..)+  , toPostWithPicked+  )+where++import Schema.Include.Author (PostInclude (..), PostWith (..), PostWithPicked (..), PostAuthor, PostResult, PostRead, LoadPost (..), toPostWithPicked)
+ test/Schema/Include/Shelf.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Schema.Include.Shelf+  ( ShelfInclude (..)+  , ShelfWith (..)+  , ShelfWithPicked (..)+  , ShelfBooks+  , ShelfTags+  , ShelfResult+  , ShelfRead+  , LoadShelf (..)+  , toShelfWithPicked+  )+where++import Poppy.Internal.Generated+  ( Db,+    IncludeFor,+    Load (..),+    Skip (..),+    Skipped,+    ValidEdge,+    skipped,+    OmitSelect (..),+    findByIn,+    indexHasMany,+    lookupGroups+  )+import Schema.Shelf (ShelfPicked, ShelfRow (..), ShelfSelect, toShelfPicked)+import qualified Schema.Book as Book+import Schema.Book (BookRow (..), BookTable)+import qualified Schema.Tag as Tag+import Schema.Tag (TagRow (..), TagTable)+import Schema.Include.Book (BookInclude (..), BookResult, BookWith (..), LoadBook (..))++data ShelfInclude books tags = ShelfInclude+  { books :: books,+    tags :: tags+  }+  deriving (Show, Eq)++data ShelfWith books tags = ShelfWith+  { shelf :: ShelfRow,+    books :: ShelfBooks books,+    tags :: ShelfTags tags+  }++deriving instance (Eq ShelfRow, Eq (ShelfBooks books), Eq (ShelfTags tags)) => Eq (ShelfWith books tags)+deriving instance (Show ShelfRow, Show (ShelfBooks books), Show (ShelfTags tags)) => Show (ShelfWith books tags)++data ShelfWithPicked books tags = ShelfWithPicked+  { shelf :: ShelfPicked,+    books :: ShelfBooks books,+    tags :: ShelfTags tags+  }++deriving instance (Eq ShelfPicked, Eq (ShelfBooks books), Eq (ShelfTags tags)) => Eq (ShelfWithPicked books tags)+deriving instance (Show ShelfPicked, Show (ShelfBooks books), Show (ShelfTags tags)) => Show (ShelfWithPicked books tags)++toShelfWithPicked :: ShelfSelect -> ShelfWith books tags -> ShelfWithPicked books tags+toShelfWithPicked select_ nested =+  ShelfWithPicked+    { shelf = toShelfPicked select_ nested.shelf,+      books = nested.books,+      tags = nested.tags+    }++type family ShelfBooks edge where+  ShelfBooks Skip = Skipped "books" [BookRow]+  ShelfBooks (Load BookTable include) = [BookResult include]++type family ShelfTags edge where+  ShelfTags Skip = Skipped "tags" [TagRow]+  ShelfTags (Load TagTable ()) = [TagRow]++type family ShelfResult include where+  ShelfResult () = ShelfRow+  ShelfResult (ShelfInclude books tags) = ShelfWith books tags++type family ShelfRead include select where+  ShelfRead () OmitSelect = ShelfRow+  ShelfRead () ShelfSelect = ShelfPicked+  ShelfRead (ShelfInclude books tags) OmitSelect = ShelfWith books tags+  ShelfRead (ShelfInclude books tags) ShelfSelect = ShelfWithPicked books tags++class LoadShelfBooks edge where+  loadShelfBooks :: edge -> [ShelfRow] -> Db [ShelfBooks edge]++instance LoadShelfBooks Skip where+  loadShelfBooks Skip roots = pure (map (const skipped) roots)++instance LoadShelfBooks (Load BookTable ()) where+  loadShelfBooks edge roots = do+    rows <- findByIn @BookTable @BookRow Book.bookShelfId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.shelfId) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance (LoadBook chapters) => LoadShelfBooks (Load BookTable (BookInclude chapters)) where+  loadShelfBooks edge roots = do+    rows <- findByIn @BookTable @BookRow Book.bookShelfId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    loaded <- loadBook edge.include_ rows+    let grouped = indexHasMany ((.shelfId) . (.book)) loaded+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Book" edge) => LoadShelfBooks edge where+  loadShelfBooks _ roots = pure (map (const skipped) roots)++class LoadShelfTags edge where+  loadShelfTags :: edge -> [ShelfRow] -> Db [ShelfTags edge]++instance LoadShelfTags Skip where+  loadShelfTags Skip roots = pure (map (const skipped) roots)++instance LoadShelfTags (Load TagTable ()) where+  loadShelfTags edge roots = do+    rows <- findByIn @TagTable @TagRow Tag.tagShelfId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_+    let grouped = indexHasMany (.shelfId) rows+    pure [lookupGroups root.id grouped | root <- roots]++instance {-# OVERLAPPABLE #-} (ValidEdge "Tag" edge) => LoadShelfTags edge where+  loadShelfTags _ roots = pure (map (const skipped) roots)++class LoadShelf books tags where+  loadShelf :: ShelfInclude books tags -> [ShelfRow] -> Db [ShelfWith books tags]++instance (LoadShelfBooks books, LoadShelfTags tags, ValidEdge "Book" books, ValidEdge "Tag" tags) => LoadShelf books tags where+  loadShelf include roots = do+    booksLoaded <- loadShelfBooks include.books roots+    tagsLoaded <- loadShelfTags include.tags roots+    pure+      [ ShelfWith+          { shelf = root,+            books = booksLoaded !! n,+            tags = tagsLoaded !! n+          }+      | (n, root) <- zip [0 :: Int ..] roots+      ]++instance (ValidEdge "Book" books, ValidEdge "Tag" tags) => IncludeFor "Shelf" (ShelfInclude books tags)+
+ test/Schema/Packet.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Packet+  ( PacketTable (..),+    PacketRow (..),+    PacketSelect (..),+    PacketPicked (..),+    packetSelect,+    packetSelectColumns,+    parsePacketPicked,+    toPacketPicked,+    PacketCreate (..),+    PacketUpdate (..),+    packetId,+    packetAmount,+    packetPayload+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Data.Scientific (Scientific)+import Data.Aeson (Value)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data PacketTable = PacketTable++type instance PrimaryKeyType PacketTable = UUID++type instance ModelTable "Packet" = PacketTable++instance Entity PacketTable where+  tableName = "test_packet"+  primaryKey = packetId+  tableColumns = ["id", "amount", "payload"]++instance Insertable PacketTable where+  type CreateInput PacketTable = PacketCreate+  toInsertBuilder input =+    setMaybe packetId input.id $+      set packetAmount input.amount $+      set packetPayload input.payload $+      emptyInsert @PacketTable+++instance Updatable PacketTable where+  type UpdateInput PacketTable = PacketUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe packetAmount input.amount $+      setFieldMaybe packetPayload input.payload $+      emptyUpdate @PacketTable+++data PacketRow = PacketRow+  { id :: UUID,+    amount :: Scientific,+    payload :: Value+  }+  deriving (Show, Eq)+++data PacketCreate = PacketCreate+  { id :: Maybe UUID,+    amount :: Scientific,+    payload :: Value+  }+  deriving (Show, Eq)+++data PacketUpdate = PacketUpdate+  { amount :: Maybe Scientific,+    payload :: Maybe Value+  }+  deriving (Show, Eq)+++instance FromRow PacketRow where+  fromRow = PacketRow <$> field <*> field <*> field+++data PacketSelect = PacketSelect+  { id :: Bool,+    amount :: Bool,+    payload :: Bool+  }+  deriving (Show, Eq)+data PacketPicked = PacketPicked+  { id :: UUID,+    amount :: Picked Scientific,+    payload :: Picked Value+  }+  deriving (Show, Eq)+packetSelect :: PacketSelect+packetSelect =+  PacketSelect+    { id = False,+      amount = False,+      payload = False+    }+packetSelectColumns :: PacketSelect -> [Text]+packetSelectColumns select_ =+  fieldColumn packetId+    : concat+      [ [fieldColumn packetAmount | select_.amount]+      , [fieldColumn packetPayload | select_.payload]+      ]+parsePacketPicked :: PacketSelect -> RowParser PacketPicked+parsePacketPicked select_ = do+  idVal <- field+  amountVal <- if select_.amount then Picked <$> field else pure Skipped+  payloadVal <- if select_.payload then Picked <$> field else pure Skipped+  pure PacketPicked { id = idVal, amount = amountVal, payload = payloadVal }+toPacketPicked :: PacketSelect -> PacketRow -> PacketPicked+toPacketPicked select_ row =+  PacketPicked+    { id = row.id,+      amount = picked select_.amount row.amount,+      payload = picked select_.payload row.payload+    }+++packetId :: Field PacketTable UUID+packetId = Field "id" "id"++packetAmount :: Field PacketTable Scientific+packetAmount = Field "amount" "amount"++packetPayload :: Field PacketTable Value+packetPayload = Field "payload" "payload"+
+ test/Schema/Post.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Post+  ( PostTable (..),+    PostRow (..),+    PostSelect (..),+    PostPicked (..),+    postSelect,+    postSelectColumns,+    parsePostPicked,+    toPostPicked,+    PostCreate (..),+    PostUpdate (..),+    postId,+    postAuthorId,+    postTitle,+    postStatus+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )+import Schema.PostStatus (PostStatus)++data PostTable = PostTable++type instance PrimaryKeyType PostTable = UUID++type instance ModelTable "Post" = PostTable++instance Entity PostTable where+  tableName = "test_post"+  primaryKey = postId+  tableColumns = ["id", "author_id", "title", "status"]++instance Insertable PostTable where+  type CreateInput PostTable = PostCreate+  toInsertBuilder input =+    setMaybe postId input.id $+      set postAuthorId input.authorId $+      set postTitle input.title $+      set postStatus input.status $+      emptyInsert @PostTable+++instance Updatable PostTable where+  type UpdateInput PostTable = PostUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe postAuthorId input.authorId $+      setFieldMaybe postTitle input.title $+      setFieldMaybe postStatus input.status $+      emptyUpdate @PostTable+++data PostRow = PostRow+  { id :: UUID,+    authorId :: UUID,+    title :: Text,+    status :: PostStatus+  }+  deriving (Show, Eq)+++data PostCreate = PostCreate+  { id :: Maybe UUID,+    authorId :: UUID,+    title :: Text,+    status :: PostStatus+  }+  deriving (Show, Eq)+++data PostUpdate = PostUpdate+  { authorId :: Maybe UUID,+    title :: Maybe Text,+    status :: Maybe PostStatus+  }+  deriving (Show, Eq)+++instance FromRow PostRow where+  fromRow = PostRow <$> field <*> field <*> field <*> field+++data PostSelect = PostSelect+  { id :: Bool,+    authorId :: Bool,+    title :: Bool,+    status :: Bool+  }+  deriving (Show, Eq)+data PostPicked = PostPicked+  { id :: UUID,+    authorId :: Picked UUID,+    title :: Picked Text,+    status :: Picked PostStatus+  }+  deriving (Show, Eq)+postSelect :: PostSelect+postSelect =+  PostSelect+    { id = False,+      authorId = False,+      title = False,+      status = False+    }+postSelectColumns :: PostSelect -> [Text]+postSelectColumns select_ =+  fieldColumn postId+    : concat+      [ [fieldColumn postAuthorId | select_.authorId]+      , [fieldColumn postTitle | select_.title]+      , [fieldColumn postStatus | select_.status]+      ]+parsePostPicked :: PostSelect -> RowParser PostPicked+parsePostPicked select_ = do+  idVal <- field+  authorIdVal <- if select_.authorId then Picked <$> field else pure Skipped+  titleVal <- if select_.title then Picked <$> field else pure Skipped+  statusVal <- if select_.status then Picked <$> field else pure Skipped+  pure PostPicked { id = idVal, authorId = authorIdVal, title = titleVal, status = statusVal }+toPostPicked :: PostSelect -> PostRow -> PostPicked+toPostPicked select_ row =+  PostPicked+    { id = row.id,+      authorId = picked select_.authorId row.authorId,+      title = picked select_.title row.title,+      status = picked select_.status row.status+    }+++postId :: Field PostTable UUID+postId = Field "id" "id"++postAuthorId :: Field PostTable UUID+postAuthorId = Field "authorId" "author_id"++postTitle :: Field PostTable Text+postTitle = Field "title" "title"++postStatus :: Field PostTable PostStatus+postStatus = Field "status" "status"+
+ test/Schema/PostStatus.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module Schema.PostStatus+  ( PostStatus (..),+    postStatusToString+  )+where++import Data.Maybe (isNothing)+import Data.Text (Text)+import Poppy.Internal.Generated+  ( FromField (..),+    ResultError (ConversionFailed, UnexpectedNull),+    returnError,+    ToField (..),+    toField,+  )++data PostStatus = Draft | Published+  deriving (Show, Eq)+++instance FromField PostStatus where+  fromField f bs+    | isNothing bs = returnError UnexpectedNull f ""+    | bs == Just "draft" = pure Draft+    | bs == Just "published" = pure Published+    | otherwise = returnError ConversionFailed f ""+++instance ToField PostStatus where+  toField = toField . postStatusToString+++postStatusToString :: PostStatus -> Text+postStatusToString Draft = "draft"+postStatusToString Published = "published"+
+ test/Schema/Section.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Section+  ( SectionTable (..),+    SectionRow (..),+    SectionSelect (..),+    SectionPicked (..),+    sectionSelect,+    sectionSelectColumns,+    parseSectionPicked,+    toSectionPicked,+    SectionCreate (..),+    SectionUpdate (..),+    sectionId,+    sectionChapterRef,+    sectionLabel+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data SectionTable = SectionTable++type instance PrimaryKeyType SectionTable = UUID++type instance ModelTable "Section" = SectionTable++instance Entity SectionTable where+  tableName = "test_section"+  primaryKey = sectionId+  tableColumns = ["id", "chapter_id", "label"]++instance Insertable SectionTable where+  type CreateInput SectionTable = SectionCreate+  toInsertBuilder input =+    setMaybe sectionId input.id $+      set sectionChapterRef input.chapterRef $+      set sectionLabel input.label $+      emptyInsert @SectionTable+++instance Updatable SectionTable where+  type UpdateInput SectionTable = SectionUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe sectionChapterRef input.chapterRef $+      setFieldMaybe sectionLabel input.label $+      emptyUpdate @SectionTable+++data SectionRow = SectionRow+  { id :: UUID,+    chapterRef :: UUID,+    label :: Text+  }+  deriving (Show, Eq)+++data SectionCreate = SectionCreate+  { id :: Maybe UUID,+    chapterRef :: UUID,+    label :: Text+  }+  deriving (Show, Eq)+++data SectionUpdate = SectionUpdate+  { chapterRef :: Maybe UUID,+    label :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow SectionRow where+  fromRow = SectionRow <$> field <*> field <*> field+++data SectionSelect = SectionSelect+  { id :: Bool,+    chapterRef :: Bool,+    label :: Bool+  }+  deriving (Show, Eq)+data SectionPicked = SectionPicked+  { id :: UUID,+    chapterRef :: Picked UUID,+    label :: Picked Text+  }+  deriving (Show, Eq)+sectionSelect :: SectionSelect+sectionSelect =+  SectionSelect+    { id = False,+      chapterRef = False,+      label = False+    }+sectionSelectColumns :: SectionSelect -> [Text]+sectionSelectColumns select_ =+  fieldColumn sectionId+    : concat+      [ [fieldColumn sectionChapterRef | select_.chapterRef]+      , [fieldColumn sectionLabel | select_.label]+      ]+parseSectionPicked :: SectionSelect -> RowParser SectionPicked+parseSectionPicked select_ = do+  idVal <- field+  chapterRefVal <- if select_.chapterRef then Picked <$> field else pure Skipped+  labelVal <- if select_.label then Picked <$> field else pure Skipped+  pure SectionPicked { id = idVal, chapterRef = chapterRefVal, label = labelVal }+toSectionPicked :: SectionSelect -> SectionRow -> SectionPicked+toSectionPicked select_ row =+  SectionPicked+    { id = row.id,+      chapterRef = picked select_.chapterRef row.chapterRef,+      label = picked select_.label row.label+    }+++sectionId :: Field SectionTable UUID+sectionId = Field "id" "id"++sectionChapterRef :: Field SectionTable UUID+sectionChapterRef = Field "chapterRef" "chapter_id"++sectionLabel :: Field SectionTable Text+sectionLabel = Field "label" "label"+
+ test/Schema/Shelf.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Shelf+  ( ShelfTable (..),+    ShelfRow (..),+    ShelfSelect (..),+    ShelfPicked (..),+    shelfSelect,+    shelfSelectColumns,+    parseShelfPicked,+    toShelfPicked,+    ShelfCreate (..),+    ShelfUpdate (..),+    shelfId,+    shelfName+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data ShelfTable = ShelfTable++type instance PrimaryKeyType ShelfTable = UUID++type instance ModelTable "Shelf" = ShelfTable++instance Entity ShelfTable where+  tableName = "test_shelf"+  primaryKey = shelfId+  tableColumns = ["id", "name"]++instance Insertable ShelfTable where+  type CreateInput ShelfTable = ShelfCreate+  toInsertBuilder input =+    setMaybe shelfId input.id $+      set shelfName input.name $+      emptyInsert @ShelfTable+++instance Updatable ShelfTable where+  type UpdateInput ShelfTable = ShelfUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe shelfName input.name $+      emptyUpdate @ShelfTable+++data ShelfRow = ShelfRow+  { id :: UUID,+    name :: Text+  }+  deriving (Show, Eq)+++data ShelfCreate = ShelfCreate+  { id :: Maybe UUID,+    name :: Text+  }+  deriving (Show, Eq)+++data ShelfUpdate = ShelfUpdate+  { name :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow ShelfRow where+  fromRow = ShelfRow <$> field <*> field+++data ShelfSelect = ShelfSelect+  { id :: Bool,+    name :: Bool+  }+  deriving (Show, Eq)+data ShelfPicked = ShelfPicked+  { id :: UUID,+    name :: Picked Text+  }+  deriving (Show, Eq)+shelfSelect :: ShelfSelect+shelfSelect =+  ShelfSelect+    { id = False,+      name = False+    }+shelfSelectColumns :: ShelfSelect -> [Text]+shelfSelectColumns select_ =+  fieldColumn shelfId+    : concat+      [ [fieldColumn shelfName | select_.name]+      ]+parseShelfPicked :: ShelfSelect -> RowParser ShelfPicked+parseShelfPicked select_ = do+  idVal <- field+  nameVal <- if select_.name then Picked <$> field else pure Skipped+  pure ShelfPicked { id = idVal, name = nameVal }+toShelfPicked :: ShelfSelect -> ShelfRow -> ShelfPicked+toShelfPicked select_ row =+  ShelfPicked+    { id = row.id,+      name = picked select_.name row.name+    }+++shelfId :: Field ShelfTable UUID+shelfId = Field "id" "id"++shelfName :: Field ShelfTable Text+shelfName = Field "name" "name"+
+ test/Schema/Tag.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Tag+  ( TagTable (..),+    TagRow (..),+    TagSelect (..),+    TagPicked (..),+    tagSelect,+    tagSelectColumns,+    parseTagPicked,+    toTagPicked,+    TagCreate (..),+    TagUpdate (..),+    tagId,+    tagShelfId,+    tagLabel+  )+where++import Data.Text (Text)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    set,+    setMaybe,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe+  )++data TagTable = TagTable++type instance PrimaryKeyType TagTable = UUID++type instance ModelTable "Tag" = TagTable++instance Entity TagTable where+  tableName = "test_tag"+  primaryKey = tagId+  tableColumns = ["id", "shelf_id", "label"]++instance Insertable TagTable where+  type CreateInput TagTable = TagCreate+  toInsertBuilder input =+    setMaybe tagId input.id $+      set tagShelfId input.shelfId $+      set tagLabel input.label $+      emptyInsert @TagTable+++instance Updatable TagTable where+  type UpdateInput TagTable = TagUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe tagShelfId input.shelfId $+      setFieldMaybe tagLabel input.label $+      emptyUpdate @TagTable+++data TagRow = TagRow+  { id :: UUID,+    shelfId :: UUID,+    label :: Text+  }+  deriving (Show, Eq)+++data TagCreate = TagCreate+  { id :: Maybe UUID,+    shelfId :: UUID,+    label :: Text+  }+  deriving (Show, Eq)+++data TagUpdate = TagUpdate+  { shelfId :: Maybe UUID,+    label :: Maybe Text+  }+  deriving (Show, Eq)+++instance FromRow TagRow where+  fromRow = TagRow <$> field <*> field <*> field+++data TagSelect = TagSelect+  { id :: Bool,+    shelfId :: Bool,+    label :: Bool+  }+  deriving (Show, Eq)+data TagPicked = TagPicked+  { id :: UUID,+    shelfId :: Picked UUID,+    label :: Picked Text+  }+  deriving (Show, Eq)+tagSelect :: TagSelect+tagSelect =+  TagSelect+    { id = False,+      shelfId = False,+      label = False+    }+tagSelectColumns :: TagSelect -> [Text]+tagSelectColumns select_ =+  fieldColumn tagId+    : concat+      [ [fieldColumn tagShelfId | select_.shelfId]+      , [fieldColumn tagLabel | select_.label]+      ]+parseTagPicked :: TagSelect -> RowParser TagPicked+parseTagPicked select_ = do+  idVal <- field+  shelfIdVal <- if select_.shelfId then Picked <$> field else pure Skipped+  labelVal <- if select_.label then Picked <$> field else pure Skipped+  pure TagPicked { id = idVal, shelfId = shelfIdVal, label = labelVal }+toTagPicked :: TagSelect -> TagRow -> TagPicked+toTagPicked select_ row =+  TagPicked+    { id = row.id,+      shelfId = picked select_.shelfId row.shelfId,+      label = picked select_.label row.label+    }+++tagId :: Field TagTable UUID+tagId = Field "id" "id"++tagShelfId :: Field TagTable UUID+tagShelfId = Field "shelfId" "shelf_id"++tagLabel :: Field TagTable Text+tagLabel = Field "label" "label"+
+ test/Schema/Widget.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Widget+  ( WidgetTable (..),+    WidgetRow (..),+    WidgetSelect (..),+    WidgetPicked (..),+    widgetSelect,+    widgetSelectColumns,+    parseWidgetPicked,+    toWidgetPicked,+    WidgetCreate (..),+    WidgetUpdate (..),+    widgetId,+    widgetCreatedAt,+    widgetUpdatedAt,+    widgetName,+    widgetDescription+  )+where++import Data.Text (Text)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Poppy.Internal.Generated+  ( FromRow (..),+    RowParser,+    field,+    Entity (..),+    Field (..),+    PrimaryKeyType,+    ModelTable,+    Picked (..),+    picked,+    Insertable (..),+    emptyInsert,+    NullableValue (..),+    set,+    setMaybe,+    setNullable,+    Updatable (..),+    emptyUpdate,+    setFieldMaybe,+    setFieldNullable+  )++data WidgetTable = WidgetTable++type instance PrimaryKeyType WidgetTable = UUID++type instance ModelTable "Widget" = WidgetTable++instance Entity WidgetTable where+  tableName = "test_widget"+  primaryKey = widgetId+  tableColumns = ["id", "created_at", "updated_at", "name", "description"]+  uniqueKeys = [["id"], ["name"]]++instance Insertable WidgetTable where+  type CreateInput WidgetTable = WidgetCreate+  toInsertBuilder input =+    setMaybe widgetId input.id $+      setMaybe widgetCreatedAt input.createdAt $+      setMaybe widgetUpdatedAt input.updatedAt $+      set widgetName input.name $+      setNullable widgetDescription input.description $+      emptyInsert @WidgetTable+++instance Updatable WidgetTable where+  type UpdateInput WidgetTable = WidgetUpdate+  updatedAtField = Just widgetUpdatedAt+  toUpdateBuilder input =+    setFieldMaybe widgetCreatedAt input.createdAt $+      setFieldMaybe widgetUpdatedAt input.updatedAt $+      setFieldMaybe widgetName input.name $+      setFieldNullable widgetDescription input.description $+      emptyUpdate @WidgetTable+++data WidgetRow = WidgetRow+  { id :: UUID,+    createdAt :: UTCTime,+    updatedAt :: UTCTime,+    name :: Text,+    description :: Maybe Text+  }+  deriving (Show, Eq)+++data WidgetCreate = WidgetCreate+  { id :: Maybe UUID,+    createdAt :: Maybe UTCTime,+    updatedAt :: Maybe UTCTime,+    name :: Text,+    description :: NullableValue Text+  }+  deriving (Show, Eq)+++data WidgetUpdate = WidgetUpdate+  { createdAt :: Maybe UTCTime,+    updatedAt :: Maybe UTCTime,+    name :: Maybe Text,+    description :: NullableValue Text+  }+  deriving (Show, Eq)+++instance FromRow WidgetRow where+  fromRow = WidgetRow <$> field <*> field <*> field <*> field <*> field+++data WidgetSelect = WidgetSelect+  { id :: Bool,+    createdAt :: Bool,+    updatedAt :: Bool,+    name :: Bool,+    description :: Bool+  }+  deriving (Show, Eq)+data WidgetPicked = WidgetPicked+  { id :: UUID,+    createdAt :: Picked UTCTime,+    updatedAt :: Picked UTCTime,+    name :: Picked Text,+    description :: Picked (Maybe Text)+  }+  deriving (Show, Eq)+widgetSelect :: WidgetSelect+widgetSelect =+  WidgetSelect+    { id = False,+      createdAt = False,+      updatedAt = False,+      name = False,+      description = False+    }+widgetSelectColumns :: WidgetSelect -> [Text]+widgetSelectColumns select_ =+  fieldColumn widgetId+    : concat+      [ [fieldColumn widgetCreatedAt | select_.createdAt]+      , [fieldColumn widgetUpdatedAt | select_.updatedAt]+      , [fieldColumn widgetName | select_.name]+      , [fieldColumn widgetDescription | select_.description]+      ]+parseWidgetPicked :: WidgetSelect -> RowParser WidgetPicked+parseWidgetPicked select_ = do+  idVal <- field+  createdAtVal <- if select_.createdAt then Picked <$> field else pure Skipped+  updatedAtVal <- if select_.updatedAt then Picked <$> field else pure Skipped+  nameVal <- if select_.name then Picked <$> field else pure Skipped+  descriptionVal <- if select_.description then Picked <$> field else pure Skipped+  pure WidgetPicked { id = idVal, createdAt = createdAtVal, updatedAt = updatedAtVal, name = nameVal, description = descriptionVal }+toWidgetPicked :: WidgetSelect -> WidgetRow -> WidgetPicked+toWidgetPicked select_ row =+  WidgetPicked+    { id = row.id,+      createdAt = picked select_.createdAt row.createdAt,+      updatedAt = picked select_.updatedAt row.updatedAt,+      name = picked select_.name row.name,+      description = picked select_.description row.description+    }+++widgetId :: Field WidgetTable UUID+widgetId = Field "id" "id"++widgetCreatedAt :: Field WidgetTable UTCTime+widgetCreatedAt = Field "createdAt" "created_at"++widgetUpdatedAt :: Field WidgetTable UTCTime+widgetUpdatedAt = Field "updatedAt" "updated_at"++widgetName :: Field WidgetTable Text+widgetName = Field "name" "name"++widgetDescription :: Field WidgetTable Text+widgetDescription = Field "description" "description"+
+ test/Spec.hs view
@@ -0,0 +1,42 @@+module Main (main) where++import Poppy.BelongsToSpec (belongsToSpec)+import Poppy.ClientWriteSpec (clientWriteSpec)+import Poppy.CommentSpec (commentSpec)+import Poppy.DbSpec (dbSpec)+import Poppy.EnumSpec (enumSpec)+import Poppy.ErrorsSpec (errorsSpec)+import Poppy.GroupSpec (groupSpec)+import Poppy.IncludeFailSpec (includeFailSpec)+import Poppy.IncludeSpec (includeSpec)+import Poppy.MigrateSpec (migrateSpec)+import Poppy.NestedWriteSpec (nestedWriteSpec)+import Poppy.OperationsSpec (operationsSpec)+import Poppy.RawSpec (rawSpec)+import Poppy.ScalarSpec (scalarSpec)+import Poppy.SelectSpec (selectSpec)+import Poppy.UniqueFailSpec (uniqueFailSpec)+import Poppy.WhereSpec (whereSpec)+import Support.TestDb (withTestDb)+import Test.Hspec++main :: IO ()+main = hspec $ do+  includeFailSpec+  uniqueFailSpec+  errorsSpec+  groupSpec+  whereSpec+  withTestDb $+    operationsSpec+      >> includeSpec+      >> commentSpec+      >> belongsToSpec+      >> enumSpec+      >> rawSpec+      >> selectSpec+      >> nestedWriteSpec+      >> dbSpec+      >> migrateSpec+      >> clientWriteSpec+      >> scalarSpec
+ test/Support/Assert.hs view
@@ -0,0 +1,13 @@+module Support.Assert+  ( assertRight,+    assertJust,+  )+where++assertRight :: Show e => Either e a -> IO a+assertRight (Left err) = fail (show err)+assertRight (Right x) = pure x++assertJust :: Maybe a -> IO a+assertJust Nothing = fail "expected Just"+assertJust (Just x) = pure x
+ test/Support/TestDb.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Support.TestDb+  ( TestEnv (..),+    withTestDb,+    testDatabaseUrl,+    resetTestData,+    truncateTable,+  )+where++import Control.Exception (SomeException, displayException, try)+import Control.Monad (void)+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import qualified Database.PostgreSQL.Simple as PG+import Database.PostgreSQL.Simple.Types (Query (..))+import Poppy.Internal.Core (Entity (..))+import Poppy.Internal.Db (DbPool, closePool, connect, withConn)+import Poppy.Internal.Sql (quoteIdent)+import Schema.Author (AuthorTable)+import Schema.Book (BookTable)+import Schema.Chapter (ChapterTable)+import Schema.Comment (CommentTable)+import Schema.Packet (PacketTable)+import Schema.Post (PostTable)+import Schema.Section (SectionTable)+import Schema.Shelf (ShelfTable)+import Schema.Tag (TagTable)+import Schema.Widget (WidgetTable)+import Support.TestMigrations (runTestMigrations)+import System.Environment (lookupEnv)+import Test.Hspec (Spec, SpecWith, afterAll, beforeAll, beforeWith)++newtype TestEnv = TestEnv+  { envPool :: DbPool+  }++withTestDb :: SpecWith TestEnv -> Spec+withTestDb spec =+  beforeAll setupTestEnv $+    afterAll destroyTestEnv $+      beforeWith (\env -> resetTestData env >> return env) spec++testDatabaseUrl :: IO String+testDatabaseUrl = do+  mTestUrl <- lookupEnv "TEST_DATABASE_URL"+  case mTestUrl of+    Nothing ->+      fail $+        unlines+          [ "No test database URL configured.",+            "Set TEST_DATABASE_URL.",+            "Start Postgres with: docker compose up -d",+            "Default URL: postgres://poppy:poppy@127.0.0.1:5435/poppy_test"+          ]+    Just url -> return url++setupTestEnv :: IO TestEnv+setupTestEnv = do+  databaseUrl <- testDatabaseUrl+  result <- try @SomeException $ do+    runTestMigrations databaseUrl+    connect databaseUrl+  case result of+    Left err -> fail (connectionErrorMessage databaseUrl err)+    Right pool -> return TestEnv {envPool = pool}++connectionErrorMessage :: String -> SomeException -> String+connectionErrorMessage databaseUrl err =+  unlines+    [ "Could not connect to the test database.",+      displayException err,+      "",+      "URL: " <> databaseUrl,+      "",+      "Start the test database with:",+      "  docker compose up -d",+      "",+      "Then:",+      "  TEST_DATABASE_URL=postgres://poppy:poppy@127.0.0.1:5435/poppy_test cabal test all"+    ]++destroyTestEnv :: TestEnv -> IO ()+destroyTestEnv TestEnv {envPool = pool} =+  closePool pool++resetTestData :: TestEnv -> IO ()+resetTestData env = do+  truncateTable @WidgetTable env+  truncateTable @SectionTable env+  truncateTable @ChapterTable env+  truncateTable @BookTable env+  truncateTable @TagTable env+  truncateTable @ShelfTable env+  truncateTable @PostTable env+  truncateTable @AuthorTable env+  truncateTable @CommentTable env+  truncateTable @PacketTable env++truncateTable ::+  forall table.+  (Entity table) =>+  TestEnv ->+  IO ()+truncateTable TestEnv {envPool = pool} =+  withConn pool $ \conn ->+    void $+      PG.execute_+        conn+        (Query (TE.encodeUtf8 ("TRUNCATE " <> quoteIdent (tableName @table) <> " RESTART IDENTITY CASCADE" :: Text)))
+ test/Support/TestMigrations.hs view
@@ -0,0 +1,44 @@+module Support.TestMigrations+  ( runTestMigrations,+  )+where++import Control.Exception (Handler (..), catches, throwIO)+import Control.Monad (forM_, void)+import qualified Data.ByteString.Char8 as B8+import Data.Char (isSpace)+import Data.List (sort)+import Database.PostgreSQL.Simple (Connection, SqlError (..), connectPostgreSQL, execute_)+import Database.PostgreSQL.Simple.Types (Query (..))+import System.Directory (listDirectory)+import System.FilePath ((</>))++testMigrationsDir :: FilePath+testMigrationsDir = "test/migrations"++runTestMigrations :: String -> IO ()+runTestMigrations databaseUrl = do+  conn <- connectPostgreSQL $ B8.pack databaseUrl+  names <- sort <$> listDirectory testMigrationsDir+  forM_ names $ \name -> do+    sql <- B8.readFile (testMigrationsDir </> name)+    forM_ (splitStatements sql) $ \stmt ->+      executeIgnoringDuplicate conn stmt++splitStatements :: B8.ByteString -> [B8.ByteString]+splitStatements =+  filter (not . B8.null) . map stripBytes . B8.split ';'++executeIgnoringDuplicate :: Connection -> B8.ByteString -> IO ()+executeIgnoringDuplicate conn stmt =+  void (execute_ conn (Query stmt))+    `catches` [Handler ignoreDuplicate]+  where+    ignoreDuplicate err+      | sqlState err == "42710" = pure ()+      | sqlState err == "42P07" = pure () -- relation already exists (replayed UNIQUE)+      | otherwise = throwIO err++stripBytes :: B8.ByteString -> B8.ByteString+stripBytes =+  B8.reverse . B8.dropWhile isSpace . B8.reverse . B8.dropWhile isSpace
+ test/migrations/001-test-widget.sql view
@@ -0,0 +1,9 @@+CREATE EXTENSION IF NOT EXISTS "uuid-ossp";++CREATE TABLE IF NOT EXISTS test_widget (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  created_at TIMESTAMPTZ(6) NOT NULL DEFAULT CURRENT_TIMESTAMP,+  updated_at TIMESTAMPTZ(6) NOT NULL DEFAULT CURRENT_TIMESTAMP,+  name TEXT NOT NULL,+  description TEXT+);
+ test/migrations/002-test-shelf-book.sql view
@@ -0,0 +1,10 @@+CREATE TABLE IF NOT EXISTS test_shelf (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  name TEXT NOT NULL+);++CREATE TABLE IF NOT EXISTS test_book (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  shelf_id UUID NOT NULL REFERENCES test_shelf (id),+  title TEXT NOT NULL+);
+ test/migrations/003-test-chapter.sql view
@@ -0,0 +1,5 @@+CREATE TABLE IF NOT EXISTS test_chapter (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  book_id UUID NOT NULL REFERENCES test_book (id) ON DELETE CASCADE,+  heading TEXT NOT NULL+);
+ test/migrations/004-test-section.sql view
@@ -0,0 +1,5 @@+CREATE TABLE IF NOT EXISTS test_section (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  chapter_id UUID NOT NULL REFERENCES test_chapter (id) ON DELETE CASCADE,+  label TEXT NOT NULL+);
+ test/migrations/005-test-tag.sql view
@@ -0,0 +1,5 @@+CREATE TABLE IF NOT EXISTS test_tag (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  shelf_id UUID NOT NULL REFERENCES test_shelf (id),+  label TEXT NOT NULL+);
+ test/migrations/006-test-author-post.sql view
@@ -0,0 +1,13 @@+CREATE TYPE poststatus AS ENUM ('draft', 'published');++CREATE TABLE IF NOT EXISTS test_author (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  name TEXT NOT NULL+);++CREATE TABLE IF NOT EXISTS test_post (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  author_id UUID NOT NULL REFERENCES test_author (id),+  title TEXT NOT NULL,+  status poststatus NOT NULL+);
+ test/migrations/007-test-packet.sql view
@@ -0,0 +1,5 @@+CREATE TABLE IF NOT EXISTS test_packet (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  amount NUMERIC NOT NULL,+  payload JSONB NOT NULL+);
+ test/migrations/008-test-comment.sql view
@@ -0,0 +1,5 @@+CREATE TABLE IF NOT EXISTS test_comment (+  id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY,+  parent_id UUID REFERENCES test_comment (id),+  body TEXT NOT NULL+);
+ test/migrations/009-test-widget-name-unique.sql view
@@ -0,0 +1,1 @@+ALTER TABLE test_widget ADD CONSTRAINT test_widget_name_key UNIQUE (name);
+ unique-fail/NonUniqueFilter.hs view
@@ -0,0 +1,9 @@+module NonUniqueFilter where++import Poppy (eq)+import qualified Schema.Client.Widget as Widget+import Schema.Widget (widgetName)++bad =+  Widget.findUnique+    Widget.emptyQuery {Widget.where_ = Just (eq widgetName "sage")}