packages feed

poppy-codegen (empty) → 1.0.0

raw patch · 62 files changed

+8762/−0 lines, 62 filesdep +basedep +bytestringdep +containers

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

Files

+ CHANGELOG.md view
@@ -0,0 +1,32 @@+# Changelog++All notable changes to `poppy-codegen` 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` (`poppy >= 1.0 && < 1.1` for this release).+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 Schema builder, Client emission, `--check`, and `--check-schema`.++- Only `Poppy.Codegen.Schema` and `Poppy.Codegen.CLI` are exposed. `Schema`, `Model`,+  `FieldSpec`, and `RelationSpec` are abstract. Generated modules import+  `Poppy.Internal.Generated`.+- Haddock on the public modules. Guides: repository `docs/`.+- `--check-schema` reads `DATABASE_URL` only. Pass `--database-url URL` to override it.+- Model modules no longer emit `HasMany` / `BelongsTo` values.+- Include and nested-write fields use the relation name. Models with relations emit+  `Schema.Include.<Model>` (`skip` / `load` / `loadWith`, with edge `where_` /+  `orderBy_` / `take_`).+- Clients emit `<Model>Unique` / `<Model>UniqueKey`. Nested writes live on `create` /+  `update` relation fields.+- Nested-write Clients import root scalar types required by re-emitted create/update+  payloads (`UTCTime`, `NullableValue`, …).++## 0.1.0.0 — 2026-09-17++First release. Schema builder, `generate` Client emission, `--check` freshness, and `--check-schema` drift against live Postgres.
+ 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,28 @@+# poppy-codegen++The code generator for [Poppy](https://github.com/hnerdrum/poppy), a Postgres ORM for Haskell. You describe tables with `Poppy.Codegen.Schema`, then call `generate` from an executable to write table types and a client for the [`poppy`](https://github.com/hnerdrum/poppy/tree/main/poppy) runtime.++```haskell+module Main (main) where++import Poppy.Codegen.CLI (generate)+import TaskSchema (taskSchema)++main :: IO ()+main = generate "src/Schema" taskSchema+```++`generate` takes an output directory and the schema value. The directory sets the module prefix, so `src/Schema` produces modules under `Schema`, with the clients in `src/Schema/Client`.++The executable accepts the following flags:++| Flag             | Purpose                                             |+| ---------------- | --------------------------------------------------- |+| _(none)_         | Validate Schemas and write generated files          |+| `--check`        | Fail if generated files on disk differ from Codegen |+| `--check-schema` | Compare Schema to live Postgres database            |+| `--list`         | Print output paths without writing                  |++`--check-schema` reads `DATABASE_URL`. Pass `--database-url URL` to override it. The check fails if tables, columns, or keys do not match the schema.++The [repository README](https://github.com/hnerdrum/poppy#readme) shows the full setup. For working code, see [`examples/task/`](https://github.com/hnerdrum/poppy/tree/main/examples/task) and [`examples/blog/`](https://github.com/hnerdrum/poppy/tree/main/examples/blog). The [guides](https://github.com/hnerdrum/poppy/tree/main/docs) cover the schema builder and migrations in more depth.
+ poppy-codegen.cabal view
@@ -0,0 +1,154 @@+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-codegen+version:        1.0.0+synopsis:       Schema builder and Client codegen for Poppy+description:    Write a Schema, generate table types and a Client, and compare that+                Schema to live 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/009-test-widget-name-unique.sql+    test/Poppy/Codegen/golden/Article.hs.golden+    test/Poppy/Codegen/golden/Author.hs.golden+    test/Poppy/Codegen/golden/Book.hs.golden+    test/Poppy/Codegen/golden/Chapter.hs.golden+    test/Poppy/Codegen/golden/Comment.hs.golden+    test/Poppy/Codegen/golden/Editor.hs.golden+    test/Poppy/Codegen/golden/Flag.hs.golden+    test/Poppy/Codegen/golden/Packet.hs.golden+    test/Poppy/Codegen/golden/Post.hs.golden+    test/Poppy/Codegen/golden/PostStatus.hs.golden+    test/Poppy/Codegen/golden/Section.hs.golden+    test/Poppy/Codegen/golden/Shelf.hs.golden+    test/Poppy/Codegen/golden/ShelfReadClient.hs.golden+    test/Poppy/Codegen/golden/Tag.hs.golden+    test/Poppy/Codegen/golden/Widget.hs.golden+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/hnerdrum/poppy++library+  exposed-modules:+      Poppy.Codegen.CLI+      Poppy.Codegen.Schema+  other-modules:+      Poppy.Codegen.Drift+      Poppy.Codegen.Emit.Client+      Poppy.Codegen.Emit.Include+      Poppy.Codegen.Emit.NestedWrite+      Poppy.Codegen.Emit.Schema+      Poppy.Codegen.EmitCommon+      Poppy.Codegen.IR+      Poppy.Codegen.Introspect+      Poppy.Codegen.Lookup+      Poppy.Codegen.Run+      Poppy.Codegen.Target+      Poppy.Codegen.TextUtil+      Poppy.Codegen.Validate+  hs-source-dirs:+      src+  default-extensions:+      NamedFieldPuns+      OverloadedRecordDot+      OverloadedStrings+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.17 && <4.21+    , containers >=0.6 && <0.8+    , directory ==1.3.*+    , filepath >=1.4 && <1.6+    , poppy ==1.0.*+    , postgresql-simple >=0.6 && <0.8+    , text >=2.0 && <2.2+  default-language: Haskell2010++test-suite poppy-codegen-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Poppy.Codegen.DriftSpec+      Poppy.Codegen.EmitClientSpec+      Poppy.Codegen.EmitIncludeSpec+      Poppy.Codegen.EmitSpec+      Poppy.Codegen.SchemaSpec+      Poppy.Codegen.Spec.Author+      Poppy.Codegen.Spec.Comment+      Poppy.Codegen.Spec.Editor+      Poppy.Codegen.Spec.Example+      Poppy.Codegen.Spec.Flag+      Poppy.Codegen.Spec.Packet+      Poppy.Codegen.Spec.Shelf+      Poppy.Codegen.Spec.ShelfDeep+      Poppy.Codegen.Spec.Widget+      Poppy.Codegen.TargetSpec+      Poppy.Codegen.TestTarget+      Poppy.Codegen.ValidateSpec+      Support.TestDb+      Support.TestMigrations+      Poppy.Codegen.CLI+      Poppy.Codegen.Drift+      Poppy.Codegen.Emit.Client+      Poppy.Codegen.Emit.Include+      Poppy.Codegen.Emit.NestedWrite+      Poppy.Codegen.Emit.Schema+      Poppy.Codegen.EmitCommon+      Poppy.Codegen.Introspect+      Poppy.Codegen.IR+      Poppy.Codegen.Lookup+      Poppy.Codegen.Run+      Poppy.Codegen.Schema+      Poppy.Codegen.Target+      Poppy.Codegen.TextUtil+      Poppy.Codegen.Validate+      Paths_poppy_codegen+  hs-source-dirs:+      test+      src+  default-extensions:+      AllowAmbiguousTypes+      NamedFieldPuns+      OverloadedRecordDot+      OverloadedStrings+      TypeApplications+  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:+      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+    , resource-pool ==0.4.*+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , uuid ==1.3.*+  default-language: Haskell2010
+ src/Poppy/Codegen/CLI.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Codegen CLI: write files, @--check@ freshness, @--check-schema@ drift, @--list@ paths.+module Poppy.Codegen.CLI+  ( generate,+    mainWith,+    simpleTarget,+    CodegenTarget,+  )+where++import Data.Text (Text, pack)+import qualified Data.Text.IO as TIO+import Poppy.Codegen.Drift (checkSchema, formatDriftError)+import Poppy.Codegen.IR (Schema)+import Poppy.Codegen.Introspect (introspectCatalog)+import Poppy.Codegen.Run (GenOutput (..), allOutputs, checkOutputs, schemasForTargets, writeOutputs)+import Poppy.Codegen.Target+  ( CodegenTarget,+    simpleTarget,+    targetSchemas,+  )+import Poppy.Codegen.Validate (ValidationError (..), validateSchema)+import Poppy.Internal.Db (closePool, connect, withConn)+import System.Directory (getCurrentDirectory)+import System.Environment (getArgs, lookupEnv)+import System.Exit (exitFailure, exitSuccess)++-- | Write table types and a Client under @dir@ (@src/Schema@ → module prefix @Schema@).+--+-- Flags on the process argv: none (write), @--check@, @--check-schema@, @--list@.+-- @--check-schema@ reads @DATABASE_URL@, or the URL passed as @--database-url@.+generate :: FilePath -> Schema -> IO ()+generate dir schema = mainWith [simpleTarget dir schema]++-- | Flags: none (write files), @--check@, @--check-schema@, @--list@.+--+-- @--check-schema@ may be followed by @--database-url URL@, which overrides+-- @DATABASE_URL@. The two arguments can appear in either order.+mainWith :: [CodegenTarget] -> IO ()+mainWith targets = do+  root <- getCurrentDirectory+  args <- getArgs+  case args of+    ("--check" : _) -> runCheck root targets+    ("--list" : _) -> runList targets+    _ | "--check-schema" `elem` args -> do+      urlFlag <- checkSchemaDatabaseUrl args+      runCheckSchema urlFlag targets+    _ -> runWrite root targets++runWrite :: FilePath -> [CodegenTarget] -> IO ()+runWrite root targets = do+  validateOrExit (schemasForTargets targets)+  writeOutputs root targets+  TIO.putStrLn $ "Wrote " <> pack (show (length (allOutputs targets))) <> " generated files."++runCheck :: FilePath -> [CodegenTarget] -> IO ()+runCheck root targets = do+  validateOrExit (schemasForTargets targets)+  stale <- checkOutputs root targets+  case stale of+    [] -> exitSuccess+    paths -> do+      TIO.putStrLn "Generated files are out of date. Re-run codegen without --check."+      mapM_ (TIO.putStrLn . ("  " <>)) (pack <$> paths)+      exitFailure++runCheckSchema :: Maybe String -> [CodegenTarget] -> IO ()+runCheckSchema urlFlag targets = do+  let schemas = targetSchemas targets+  validateOrExit schemas+  url <- schemaDatabaseUrl urlFlag+  pool <- connect url+  catalog <- withConn pool introspectCatalog+  closePool pool+  case concatMap (`checkSchema` catalog) schemas of+    [] -> exitSuccess+    errs -> do+      TIO.putStrLn "IR does not match the database. Haskell IR is the source of truth."+      mapM_ (TIO.putStrLn . ("  " <>) . formatDriftError) errs+      exitFailure++-- | @--database-url@ overrides @DATABASE_URL@. Other arguments besides+-- @--check-schema@ are rejected.+checkSchemaDatabaseUrl :: [String] -> IO (Maybe String)+checkSchemaDatabaseUrl = go Nothing+  where+    go found [] = pure found+    go found ("--check-schema" : rest) = go found rest+    go found ("--database-url" : url : rest)+      | isOption url = missingUrl+      | otherwise =+          case found of+            Just _ -> do+              TIO.putStrLn "--database-url was given more than once."+              exitFailure+            Nothing -> go (Just url) rest+    go _ ("--database-url" : _) = missingUrl+    go _ (other : _) = do+      TIO.putStrLn $ "Unknown argument: " <> pack other <> "."+      TIO.putStrLn "Usage: --check-schema [--database-url URL]"+      exitFailure+    missingUrl = do+      TIO.putStrLn "--database-url requires a URL."+      exitFailure+    isOption ('-' : '-' : _) = True+    isOption _ = False++schemaDatabaseUrl :: Maybe String -> IO String+schemaDatabaseUrl (Just url) = pure url+schemaDatabaseUrl Nothing = do+  mDb <- lookupEnv "DATABASE_URL"+  case mDb of+    Just url -> pure url+    Nothing -> do+      TIO.putStrLn "Set DATABASE_URL, or pass --database-url URL, to check the Schema against Postgres."+      exitFailure++runList :: [CodegenTarget] -> IO ()+runList targets = mapM_ (TIO.putStrLn . pack . outputPath) (allOutputs targets)++validateOrExit :: [Schema] -> IO ()+validateOrExit schemas =+  case concatMap validateSchema schemas of+    [] -> pure ()+    errs -> do+      TIO.putStrLn "Schema validation failed:"+      mapM_ (TIO.putStrLn . ("  " <>) . formatValidationError) errs+      exitFailure++formatValidationError :: ValidationError -> Text+formatValidationError err = pack (show err)
+ src/Poppy/Codegen/Drift.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Compare a Schema to live Postgres. Poppy does not generate migrations.+module Poppy.Codegen.Drift+  ( DbCatalog (..),+    DbTable (..),+    DbColumn (..),+    DbForeignKey (..),+    DriftError (..),+    emptyCatalog,+    checkSchema,+    formatDriftError,+  )+where++import Data.List (find, nub, sort)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.IR hiding (field, variant)+import Poppy.Codegen.TextUtil (lowerFirst)++data DbCatalog = DbCatalog+  { dbTables :: Map Text DbTable,+    dbEnums :: Map Text [Text],+    dbForeignKeys :: [DbForeignKey]+  }+  deriving (Show, Eq)++data DbTable = DbTable+  { dbTableName :: Text,+    dbColumns :: Map Text DbColumn,+    dbPrimaryKey :: [Text],+    dbUniques :: [Set Text]+  }+  deriving (Show, Eq)++data DbColumn = DbColumn+  { dbColName :: Text,+    dbColType :: Text,+    dbColNullable :: Bool,+    dbColDefault :: Maybe Text+  }+  deriving (Show, Eq)++data DbForeignKey = DbForeignKey+  { dbFkFromTable :: Text,+    dbFkFromColumn :: Text,+    dbFkToTable :: Text,+    dbFkToColumn :: Text+  }+  deriving (Show, Eq)++data DriftError+  = DriftMissingTable Text Text+  | DriftMissingColumn Text Text+  | DriftExtraColumn Text Text+  | DriftNullability Text Text Bool Bool+  | DriftType Text Text Text Text+  | DriftPrimaryKey Text [Text] [Text]+  | DriftMissingUnique Text [Text]+  | DriftUnexpectedUnique Text [Text]+  | DriftMissingEnum Text Text+  | DriftEnumLabels Text [Text] [Text]+  | DriftMissingDefault Text Text FieldDefault+  | DriftDefaultMismatch Text Text FieldDefault Text+  | DriftMissingForeignKey Text Text Text Text+  deriving (Show, Eq)++emptyCatalog :: DbCatalog+emptyCatalog =+  DbCatalog+    { dbTables = Map.empty,+      dbEnums = Map.empty,+      dbForeignKeys = []+    }++checkSchema :: Schema -> DbCatalog -> [DriftError]+checkSchema schema catalog =+  concatMap (checkModel catalog) (schemaModels schema)+    ++ concatMap (checkEnum catalog) (schemaEnums schema)+    ++ concatMap (checkMissingUnique catalog schema) (schemaUniques schema)+    ++ concatMap (checkUnexpectedUniques catalog schema) (schemaModels schema)+    ++ checkForeignKeys catalog schema++formatDriftError :: DriftError -> Text+formatDriftError = \case+  DriftMissingTable model table ->+    "IR model " <> model <> " table " <> table <> " is missing from the database"+  DriftMissingColumn table col ->+    "IR column " <> table <> "." <> col <> " is missing from the database"+  DriftExtraColumn table col ->+    "database column " <> table <> "." <> col <> " is not in the IR"+  DriftNullability table col irNull dbNull ->+    "nullability drift on "+      <> table+      <> "."+      <> col+      <> ": IR nullable="+      <> showBool irNull+      <> " database nullable="+      <> showBool dbNull+  DriftType table col expected actual ->+    "type drift on " <> table <> "." <> col <> ": IR " <> expected <> " database " <> actual+  DriftPrimaryKey table expected actual ->+    "primary key drift on " <> table <> ": IR " <> csv expected <> " database " <> csv actual+  DriftMissingUnique table cols ->+    "IR unique (" <> csv cols <> ") is missing from " <> table+  DriftUnexpectedUnique table cols ->+    "database unique (" <> csv cols <> ") on " <> table <> " is not in the IR"+  DriftMissingEnum name dbName ->+    "IR enum " <> name <> " (database type " <> dbName <> ") is missing"+  DriftEnumLabels name expected actual ->+    "enum " <> name <> " labels: IR " <> csv expected <> " database " <> csv actual+  DriftMissingDefault table col expected ->+    "IR column "+      <> table+      <> "."+      <> col+      <> " declares DEFAULT "+      <> defaultLabel expected+      <> " but the database has none"+  DriftDefaultMismatch table col expected actual ->+    "default drift on "+      <> table+      <> "."+      <> col+      <> ": IR "+      <> defaultLabel expected+      <> " database "+      <> actual+  DriftMissingForeignKey fromTable fromCol toTable toCol ->+    "IR foreign key "+      <> fromTable+      <> "."+      <> fromCol+      <> " → "+      <> toTable+      <> "."+      <> toCol+      <> " is missing from the database"++showBool :: Bool -> Text+showBool True = "true"+showBool False = "false"++csv :: [Text] -> Text+csv = T.intercalate ", "++checkModel :: DbCatalog -> Model -> [DriftError]+checkModel catalog model =+  case Map.lookup (modelTable model) (dbTables catalog) of+    Nothing ->+      [DriftMissingTable (modelName model) (modelTable model)]+    Just table ->+      concatMap (checkColumn table) (modelFields model)+        ++ extraColumns table (modelFields model)+        ++ checkPrimaryKey table model++checkColumn :: DbTable -> FieldSpec -> [DriftError]+checkColumn table spec =+  case Map.lookup (fieldColumn spec) (dbColumns table) of+    Nothing ->+      [DriftMissingColumn (dbTableName table) (fieldColumn spec)]+    Just col ->+      [ DriftNullability (dbTableName table) (fieldColumn spec) (fieldNullable spec) (dbColNullable col)+        | fieldNullable spec /= dbColNullable col+      ]+        ++ [ DriftType (dbTableName table) (fieldColumn spec) expected (dbColType col)+             | dbColType col /= expected+           ]+        ++ checkDefault (dbTableName table) (fieldColumn spec) (fieldDefault spec) (dbColDefault col)+  where+    expected = irType spec++checkDefault :: Text -> Text -> Maybe FieldDefault -> Maybe Text -> [DriftError]+checkDefault _ _ Nothing _ = []+checkDefault table col (Just expected) Nothing =+  [DriftMissingDefault table col expected]+checkDefault table col (Just expected) (Just actual) =+  [ DriftDefaultMismatch table col expected actual+    | canonicalizeDefault actual /= Just expected+  ]++canonicalizeDefault :: Text -> Maybe FieldDefault+canonicalizeDefault raw+  | mentions ["uuid_generate_v4", "gen_random_uuid"] = Just DefaultUuidV4+  | mentions ["now()", "current_timestamp"] = Just DefaultNow+  | otherwise = Nothing+  where+    normalized = T.toLower (T.strip raw)+    mentions = any (`T.isInfixOf` normalized)++defaultLabel :: FieldDefault -> Text+defaultLabel DefaultUuidV4 = "uuid_generate_v4()"+defaultLabel DefaultNow = "now()"++extraColumns :: DbTable -> [FieldSpec] -> [DriftError]+extraColumns table fields =+  [ DriftExtraColumn (dbTableName table) col+    | col <- Map.keys (dbColumns table),+      col `notElem` map fieldColumn fields+  ]++checkPrimaryKey :: DbTable -> Model -> [DriftError]+checkPrimaryKey table model =+  [ DriftPrimaryKey (modelTable model) expected actual+    | expected /= actual+  ]+  where+    expected = map fieldColumn (filter fieldIsPrimaryKey (modelFields model))+    actual = dbPrimaryKey table++checkMissingUnique :: DbCatalog -> Schema -> UniqueConstraint -> [DriftError]+checkMissingUnique catalog schema UniqueConstraint {uniqueModel, uniqueFields} =+  case find ((== uniqueModel) . modelName) (schemaModels schema) of+    Nothing -> []+    Just model ->+      case Map.lookup (modelTable model) (dbTables catalog) of+        Nothing -> []+        Just table ->+          let irCols = map (fieldColumnFor model) uniqueFields+              irSet = Set.fromList irCols+           in [ DriftMissingUnique (modelTable model) (sort irCols)+                | irSet `notElem` dbUniques table+              ]++checkUnexpectedUniques :: DbCatalog -> Schema -> Model -> [DriftError]+checkUnexpectedUniques catalog schema model =+  case Map.lookup (modelTable model) (dbTables catalog) of+    Nothing -> []+    Just table ->+      [ DriftUnexpectedUnique (dbTableName table) (sort (Set.toList dbSet))+        | dbSet <- dbUniques table,+          dbSet `notElem` irSets+      ]+  where+    irSets =+      [ Set.fromList (map (fieldColumnFor model) uniqueFields)+        | UniqueConstraint {uniqueModel, uniqueFields} <- schemaUniques schema,+          uniqueModel == modelName model+      ]++fieldColumnFor :: Model -> Text -> Text+fieldColumnFor model wanted =+  maybe+    wanted+    fieldColumn+    (find ((== wanted) . fieldName) (modelFields model))++checkEnum :: DbCatalog -> EnumSpec -> [DriftError]+checkEnum catalog enumSpec =+  case Map.lookup dbName (dbEnums catalog) of+    Nothing ->+      [DriftMissingEnum (enumName enumSpec) dbName]+    Just labels ->+      [ DriftEnumLabels (enumName enumSpec) expected (sort labels)+        | sort labels /= expected+      ]+  where+    dbName = T.toLower (enumName enumSpec)+    expected = sort (map variantSqlValue (enumVariants enumSpec))++variantSqlValue :: EnumVariant -> Text+variantSqlValue spec =+  case variantDbValue spec of+    Just value -> value+    Nothing -> lowerFirst (variantName spec)++irType :: FieldSpec -> Text+irType spec =+  case fieldType spec of+    TyText -> "text"+    TyUuid -> "uuid"+    TyInt -> "int"+    TyNumeric -> "numeric"+    TyJsonb -> "jsonb"+    TyTimestamptz -> "timestamptz"+    TyBool -> "boolean"+    TyEnum name -> "enum:" <> T.toLower name++checkForeignKeys :: DbCatalog -> Schema -> [DriftError]+checkForeignKeys catalog schema =+  [ DriftMissingForeignKey fromTable fromCol toTable toCol+    | DbForeignKey fromTable fromCol toTable toCol <- impliedForeignKeys schema,+      Map.member fromTable (dbTables catalog),+      DbForeignKey fromTable fromCol toTable toCol `notElem` dbForeignKeys catalog+  ]++impliedForeignKeys :: Schema -> [DbForeignKey]+impliedForeignKeys schema =+  nub+    [ fk+      | model <- schemaModels schema,+        rel <- modelRelations model,+        Just fk <- [relationForeignKey schema rel]+    ]++relationForeignKey :: Schema -> RelationSpec -> Maybe DbForeignKey+relationForeignKey schema rel =+  case (findModel (relFromModel rel), findModel (relToModel rel)) of+    (Just fromModel, Just toModel) ->+      Just $+        case relKind rel of+          RelHasMany ->+            DbForeignKey+              { dbFkFromTable = modelTable toModel,+                dbFkFromColumn = fieldColumn (lookupNamedField toModel (relForeignField rel)),+                dbFkToTable = modelTable fromModel,+                dbFkToColumn = fieldColumn (lookupNamedField fromModel (relLocalField rel))+              }+          RelBelongsTo ->+            DbForeignKey+              { dbFkFromTable = modelTable fromModel,+                dbFkFromColumn = fieldColumn (lookupNamedField fromModel (relForeignField rel)),+                dbFkToTable = modelTable toModel,+                dbFkToColumn = fieldColumn (lookupNamedField toModel (relLocalField rel))+              }+    _ -> Nothing+  where+    findModel name = find ((== name) . modelName) (schemaModels schema)++lookupNamedField :: Model -> Text -> FieldSpec+lookupNamedField model name =+  case find ((== name) . fieldName) (modelFields model) of+    Just spec -> spec+    Nothing ->+      error $+        "Poppy.Codegen.Drift: unknown field "+          <> T.unpack name+          <> " on "+          <> T.unpack (modelName model)
+ src/Poppy/Codegen/Emit/Client.hs view
@@ -0,0 +1,964 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Emit.Client+  ( emitClientModule,+    emitSimpleClientModule,+  )+where++import Data.List (nub)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.Emit.NestedWrite+  ( emitClientCreateManyFn,+    emitClientUpsertFn,+    emitCreateFn,+    emitNestedWriteHelpers,+    emitNestedWriteTypes,+    emitUpdateFn,+    emitUpdateManyFn,+    nestedChildClientImports,+    nestedChildEnumImports,+    nestedChildSchemaImports,+    nestedWriteExportItems,+    nestedWriteRelations,+    nestedWriteUsesTransaction,+    schemaModuleAlias,+  )+import Poppy.Codegen.Emit.Schema (enumImportLine)+import Poppy.Codegen.EmitCommon+  ( clientSchemaPrefix,+    createTypeName,+    fieldBinder,+    hsType,+    parsePickedName,+    pickedTypeName,+    primaryKeyField,+    rowTypeName,+    selectColumnsFnName,+    selectDefaultName,+    selectTypeName,+    tableTypeName,+    updateTypeName,+  )+import Poppy.Codegen.IR+import Poppy.Codegen.Lookup (lookupField, lookupUniques)+import Poppy.Codegen.TextUtil (lowerFirst, upperFirst)++emitClientModule :: Text -> Schema -> Model -> Text+emitClientModule moduleName schema model =+  if null (modelRelations model)+    then emitSimpleClientModule moduleName schema model+    else emitIncludeClientModule moduleName schema model++emitSimpleClientModule :: Text -> Schema -> Model -> Text+emitSimpleClientModule moduleName schema model =+  T.unlines+    [ "{-# LANGUAGE DuplicateRecordFields #-}",+      "{-# LANGUAGE FlexibleContexts #-}",+      "{-# LANGUAGE FlexibleInstances #-}",+      "{-# LANGUAGE LambdaCase #-}",+      "{-# LANGUAGE NamedFieldPuns #-}",+      "{-# LANGUAGE RecordWildCards #-}",+      "{-# LANGUAGE TypeApplications #-}",+      "{-# LANGUAGE TypeFamilies #-}",+      "",+      "module " <> moduleName,+      emitSimpleExports model,+      "where",+      "",+      valueImportsBlock schema moduleName model,+      simpleGeneratedImports schema model,+      "import "+        <> schemaModule moduleName model+        <> " ("+        <> createTypeName model+        <> " (..), "+        <> rowTypeName model+        <> " (..), "+        <> selectTypeName model+        <> " (..), "+        <> pickedTypeName model+        <> " (..), "+        <> selectDefaultName model+        <> ", "+        <> selectColumnsFnName model+        <> ", "+        <> parsePickedName model+        <> ", "+        <> tableTypeName model+        <> ", "+        <> updateTypeName model+        <> " (..), "+        <> uniqueFieldImportList schema model+        <> ")",+      "",+      emitUniqueDecls schema model,+      "",+      emitCreateFn schema model,+      "",+      emitClientCreateManyFn schema model,+      "",+      emitUpdateFn schema model,+      "",+      emitUpdateManyFn schema model,+      "",+      emitClientUpsertFn schema model,+      "",+      emitQueryType model,+      "",+      emitUniqueQueryType False model,+      "",+      emitEmptyQueryFn model,+      "",+      emitUniqueQueryFn False model,+      "",+      emitResolveSelect model,+      "",+      emitFindManyFn model,+      "",+      emitCountFn model,+      "",+      emitDeleteFn model,+      "",+      emitDeleteManyFn model+    ]++emitIncludeClientModule :: Text -> Schema -> Model -> Text+emitIncludeClientModule moduleName schema root =+  T.unlines+    ( [ "{-# 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 #-}",+        "",+        emitIncludeClientHeader schema root,+        "module " <> moduleName+      ]+        ++ exportLinesFromItems (includeClientExportItems schema root)+        ++ ["where", ""]+        ++ includeClientImportLines moduleName schema root+    )+    <> "\n"+    <> intercalateSections+      ( emitUniqueDecls schema root+          : filter+            (not . T.null)+            ( emitNestedWriteTypes schema root+                : [ emitCreateFn schema root,+                    emitClientCreateManyFn schema root,+                    emitUpdateFn schema root,+                    emitUpdateManyFn schema root,+                    emitClientUpsertFn schema root,+                    emitNestedWriteHelpers schema root+                  ]+                ++ emitIncludeReadDefinitions schema root+                ++ [ emitDeleteFn root,+                     emitDeleteManyFn root+                   ]+            )+      )++emitIncludeClientHeader :: Schema -> Model -> Text+emitIncludeClientHeader schema root =+  T.intercalate "\n" $+    ["{- | Generated Client. Do not edit."]+      ++ nestedDocs+      ++ ["-}"]+  where+    nestedDocs =+      case nestedWriteRelations schema root of+        [] -> []+        _ ->+          [ "",+            "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)"+          ]++emitSimpleExports :: Model -> Text+emitSimpleExports model =+  T.unlines+    [ "  ( create,",+      "    createMany,",+      "    update,",+      "    updateMany,",+      "    upsert,",+      "    findMany,",+      "    findUnique,",+      "    findUniqueOrFail,",+      "    findFirst,",+      "    findFirstOrFail,",+      "    count,",+      "    delete,",+      "    deleteMany,",+      "    " <> createTypeName model <> " (..),",+      "    " <> rowTypeName model <> " (..),",+      "    " <> selectTypeName model <> " (..),",+      "    " <> pickedTypeName model <> " (..),",+      "    " <> selectDefaultName model <> ",",+      "    OmitSelect (..),",+      "    Picked (..),",+      "    ResolveSelect,",+      "    " <> updateTypeName model <> " (..),",+      "    " <> tableTypeName model <> ",",+      "    " <> queryTypeName model <> " (..),",+      "    " <> uniqueTypeName model <> " (..),",+      "    " <> uniqueKeyTypeName model <> " (..),",+      "    " <> uniqueQueryName model <> " (..),",+      "    emptyQuery,",+      "    uniqueQuery,",+      "    " <> uniqueWhereName model <> ",",+      "    " <> fieldBinder model (primaryKeyField model),+      "  )"+    ]++exportLinesFromItems :: [Text] -> [Text]+exportLinesFromItems items =+  case items of+    [] -> ["  ()"]+    (first : rest) ->+      ("  ( " <> first) : map ("    " <>) rest ++ ["  )"]++includeClientExportItems :: Schema -> Model -> [Text]+includeClientExportItems schema root =+  includeReadFunctionExportItems+    ++ [ "create,",+         "createMany,",+         "update,",+         "updateMany,",+         "upsert,",+         "delete,",+         "deleteMany,"+       ]+    ++ nestedWriteExportItems schema root+    ++ [ queryTypeName root <> " (..),",+         uniqueTypeName root <> " (..),",+         uniqueKeyTypeName root <> " (..),",+         uniqueQueryName root <> " (..),",+         "emptyQuery,",+         "uniqueQuery,",+         uniqueWhereName root <> ",",+         "OmitSelect (..),",+         "Picked (..),",+         createTypeName root <> " (..),",+         rowTypeName root <> " (..),",+         selectTypeName root <> " (..),",+         pickedTypeName root <> " (..),",+         selectDefaultName root <> ",",+         updateTypeName root <> " (..),",+         tableTypeName root <> ",",+         fieldBinder root (primaryKeyField root)+       ]++includeReadFunctionExportItems :: [Text]+includeReadFunctionExportItems =+  [ "findMany,",+    "findUnique,",+    "findUniqueOrFail,",+    "findFirst,",+    "findFirstOrFail,",+    "count,"+  ]++includeClientImportLines :: Text -> Schema -> Model -> [Text]+includeClientImportLines moduleName schema root =+  nestedPreludeImports schema root+    ++ [ includeGeneratedImports schema root,+         rootSchemaImport moduleName schema root,+         includeModuleImportLine moduleName root+       ]+    ++ nestedChildSchemaImports moduleName schema root+    ++ nestedChildClientImports moduleName schema root+    ++ nestedChildEnumImports moduleName schema root+    ++ extraValueImports moduleName schema root++rootSchemaImport :: Text -> Schema -> Model -> Text+rootSchemaImport moduleName schema root+  | nestedWriteUsesTransaction schema root =+      T.unlines+        [ "import "+            <> schemaModule moduleName root+            <> " ("+            <> T.intercalate ", " (rootSchemaNames False)+            <> ")",+          "import qualified "+            <> schemaModule moduleName root+            <> " as "+            <> schemaModuleAlias root+            <> " ("+            <> createTypeName root+            <> " (..), "+            <> updateTypeName root+            <> " (..))"+        ]+  | otherwise =+      "import "+        <> schemaModule moduleName root+        <> " ("+        <> T.intercalate ", " (rootSchemaNames True)+        <> ")"+  where+    rootSchemaNames withCreateUpdate =+      nub $+        [n | withCreateUpdate, n <- [createTypeName root <> " (..)", updateTypeName root <> " (..)"]]+          ++ [ rowTypeName root <> " (..)",+               selectTypeName root <> " (..)",+               pickedTypeName root <> " (..)",+               selectDefaultName root,+               selectColumnsFnName root,+               parsePickedName root,+               tableTypeName root,+               uniqueFieldImportList schema root+             ]+          ++ [ fieldBinder child (lookupField child (relForeignField rel))+               | (rel, child) <- nestedWriteRelations schema root,+                 modelName child == modelName root+             ]++includeModuleImportLine :: Text -> Model -> Text+includeModuleImportLine moduleName model =+  "import "+    <> includeModule moduleName model+    <> " ("+    <> T.intercalate+      ", "+      [ "Load" <> modelName model <> " (..)",+        includeType model <> " (..)",+        readType model,+        toWithPickedName model+      ]+    <> ")"++nestedPreludeImports :: Schema -> Model -> [Text]+nestedPreludeImports schema root+  | nestedWriteUsesTransaction schema root =+      [ "import Data.Maybe (isJust)",+        "import Data.Text (Text)",+        "import Data.UUID (UUID)"+      ]+  | otherwise = ["import Data.UUID (UUID)"]++simpleGeneratedImports :: Schema -> Model -> Text+simpleGeneratedImports schema model =+  T.unlines+    [ "import Poppy.Internal.Generated",+      "  ( Db,",+      "    ORMError (..),",+      "    fromUniqueRows,",+      "    requireFound,",+      "    uniqueOrFail,",+      "    OrderBy,",+      "    QueryBuilder,",+      "    applyQueryModifiers,",+      "    matching,",+      "    selectColumns,",+      "    OmitSelect (..),",+      "    Picked (..),",+      "    " <> T.intercalate ",\n    " (whereNames schema model) <> "",+      "  )",+      "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",+      "  )"+    ]++includeGeneratedImports :: Schema -> Model -> Text+includeGeneratedImports schema root =+  let dbNames =+        if nestedWriteUsesTransaction schema root+          then ["Db", "transactionEither"]+          else ["Db"]+      nestedNames =+        if nestedWriteUsesTransaction schema root+          then+            ["fieldColumn", "toField"]+              ++ ["NullableValue (..)" | needsNestedNullableValue schema root]+          else []+      wherePart = whereNames schema root+      selectIn = ["prepareIncludeRootQuery"]+   in T.unlines+        [ "import Poppy.Internal.Generated",+          "  ( " <> T.intercalate ",\n    " (dbNames ++ nestedNames ++ ["ORMError (..)", "fromUniqueRows", "requireFound", "uniqueOrFail", "OrderBy", "applyQueryModifiers", "matching", "selectColumns", "OmitSelect (..)", "Picked (..)"] ++ selectIn ++ wherePart) <> "",+          "  )",+          "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",+          "  )"+        ]++whereNames :: Schema -> Model -> [Text]+whereNames schema model+  | nestedWriteUsesTransaction schema model = ["Where", "and_", "eq"]+  | otherwise =+      let needsAnd = any ((> 1) . length . emittedFields) (modelUniqueKeys schema model)+       in ["Where", "eq"] ++ ["and_" | needsAnd]++intercalateSections :: [Text] -> Text+intercalateSections sections =+  T.intercalate "\n\n" (map T.strip sections)++emitFindManyFn :: Model -> Text+emitFindManyFn model =+  let q = queryTypeName model+      uq = uniqueQueryName model+      table = tableTypeName model+      row = rowTypeName model+      whereFn = uniqueWhereName model+   in T.unlines $+        [ "class Read" <> modelName model <> " select where",+          "  findMany :: " <> q <> " select -> Db [ResolveSelect select]",+          "  findUnique :: " <> uq <> " select -> Db (Either ORMError (Maybe (ResolveSelect select)))",+          "  findUniqueOrFail :: " <> uq <> " select -> Db (Either ORMError (ResolveSelect select))",+          "  findFirst :: " <> q <> " select -> Db (Maybe (ResolveSelect select))",+          "  findFirstOrFail :: " <> q <> " select -> Db (Either ORMError (ResolveSelect select))",+          "",+          "instance Read" <> modelName model <> " OmitSelect where",+          "  findMany q =",+          "    Ops.findMany @" <> table <> " @" <> row <> " (applyQuery q)"+        ]+          ++ emitFindUniqueByRowsLines+            whereFn+            (uq <> " {where_}")+            ["rows <- Ops.findMany @" <> table <> " @" <> row <> " (matching w)"]+          ++ emitFindUniqueOrFailLines+          ++ [ "  findFirst q =",+               "    Ops.findFirst @" <> table <> " @" <> row <> " (applyQuery q)"+             ]+          ++ emitFindFirstOrFailLines+          ++ [ "",+               "instance Read" <> modelName model <> " " <> selectTypeName model <> " where",+               "  findMany q@" <> q <> " {select_} =",+               "    Ops.findManyWith",+               "      (" <> parsePickedName model <> " select_)",+               "      (selectColumns (" <> selectColumnsFnName model <> " select_) . applyQuery q)"+             ]+          ++ emitFindUniqueByRowsLines+            whereFn+            (uq <> " {where_, select_}")+            [ "rows <-",+              "  Ops.findManyWith",+              "    (" <> parsePickedName model <> " select_)",+              "    (selectColumns (" <> selectColumnsFnName model <> " select_) . matching w)"+            ]+          ++ emitFindUniqueOrFailLines+          ++ [ "  findFirst q@" <> q <> " {select_} =",+               "    Ops.findFirstWith",+               "      (" <> parsePickedName model <> " select_)",+               "      (selectColumns (" <> selectColumnsFnName model <> " select_) . applyQuery q)"+             ]+          ++ emitFindFirstOrFailLines+          ++ [ "",+               "applyQuery :: " <> q <> " select -> QueryBuilder " <> table <> " -> QueryBuilder " <> table,+               "applyQuery " <> q <> " {where_, orderBy_, limit_, offset_} =",+               "  applyQueryModifiers where_ orderBy_ limit_ offset_"+             ]++emitFindUniqueOrFailLines :: [Text]+emitFindUniqueOrFailLines =+  ["  findUniqueOrFail q = uniqueOrFail <$> findUnique q"]++emitFindUniqueByRowsLines :: Text -> Text -> [Text] -> [Text]+emitFindUniqueByRowsLines whereFn binding rowLines =+  [ "  findUnique " <> binding <> " = do",+    "    let w = " <> whereFn <> " where_"+  ]+    ++ map ("    " <>) rowLines+    ++ ["    pure (fromUniqueRows rows)"]++emitFindFirstOrFailLines :: [Text]+emitFindFirstOrFailLines =+  [ "  findFirstOrFail q = do",+    "    result <- findFirst q",+    "    pure $ requireFound result (RecordNotFound \"No record found matching query\")"+  ]++emitCountFn :: Model -> Text+emitCountFn model =+  T.unlines+    [ "count :: " <> queryTypeName model <> " select -> Db Int",+      "count q = Ops.count @" <> tableTypeName model <> " (applyQuery q)"+    ]++emitIncludeCountFn :: Model -> Text+emitIncludeCountFn model =+  T.unlines+    [ "count :: " <> queryTypeName model <> " include select -> Db Int",+      "count " <> queryTypeName model <> " {where_, orderBy_, limit_, offset_} =",+      "  Ops.count @" <> tableTypeName model <> " (applyQueryModifiers where_ orderBy_ limit_ offset_)"+    ]++emitResolveSelect :: Model -> Text+emitResolveSelect model =+  T.unlines+    [ "type family ResolveSelect select",+      "type instance ResolveSelect OmitSelect = " <> rowTypeName model,+      "type instance ResolveSelect " <> selectTypeName model <> " = " <> pickedTypeName model+    ]++emitEmptyQueryFn :: Model -> Text+emitEmptyQueryFn model =+  T.unlines+    [ "emptyQuery :: " <> queryTypeName model <> " OmitSelect",+      "emptyQuery =",+      "  " <> queryTypeName model <> " {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}"+    ]++emitQueryType :: Model -> Text+emitQueryType model =+  T.unlines+    [ "data " <> queryTypeName model <> " select = " <> queryTypeName model,+      "  { select_ :: select",+      "  , where_ :: Maybe (Where " <> tableTypeName model <> ")",+      "  , orderBy_ :: [OrderBy " <> tableTypeName model <> "]",+      "  , limit_ :: Maybe Int",+      "  , offset_ :: Maybe Int",+      "  }"+    ]++emitDeleteFn :: Model -> Text+emitDeleteFn model =+  T.unlines+    [ "delete :: " <> uniqueTypeName model <> " -> Db (Either ORMError Int)",+      "delete key =",+      "  Delete.deleteMany @" <> tableTypeName model <> " (" <> uniqueWhereName model <> " key)"+    ]++emitDeleteManyFn :: Model -> Text+emitDeleteManyFn model =+  T.unlines+    [ "deleteMany :: Where " <> tableTypeName model <> " -> Db (Either ORMError Int)",+      "deleteMany = Delete.deleteMany @" <> tableTypeName model+    ]++emitIncludeReadDefinitions :: Schema -> Model -> [Text]+emitIncludeReadDefinitions _schema model =+  [ emitIncludeQueryType model,+    emitUniqueQueryType True model,+    emitIncludeEmptyQueryFn model,+    emitUniqueQueryFn True model,+    emitIncludeFindManyClass model,+    emitIncludeFindManyInstances model,+    emitIncludeCountFn model+  ]++emitIncludeQueryType :: Model -> Text+emitIncludeQueryType model =+  T.unlines+    [ "data " <> queryTypeName model <> " include select = " <> queryTypeName model,+      "  { include_ :: include",+      "  , select_ :: select",+      "  , where_ :: Maybe (Where " <> tableTypeName model <> ")",+      "  , orderBy_ :: [OrderBy " <> tableTypeName model <> "]",+      "  , limit_ :: Maybe Int",+      "  , offset_ :: Maybe Int",+      "  }"+    ]++emitIncludeEmptyQueryFn :: Model -> Text+emitIncludeEmptyQueryFn model =+  T.unlines+    [ "emptyQuery :: " <> queryTypeName model <> " () OmitSelect",+      "emptyQuery =",+      "  " <> queryTypeName model <> " {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}"+    ]++emitUniqueQueryType :: Bool -> Model -> Text+emitUniqueQueryType withInclude model =+  let name = uniqueQueryName model+      params = if withInclude then " include select" else " select"+      fields =+        ["include_ :: include" | withInclude]+          ++ [ "select_ :: select",+               "where_ :: " <> uniqueTypeName model+             ]+   in T.unlines $+        ["data " <> name <> params <> " = " <> name]+          ++ zipWith fieldLine [0 :: Int ..] fields+          ++ ["  }"]+  where+    fieldLine 0 f = "  { " <> f+    fieldLine _ f = "  , " <> f++emitUniqueQueryFn :: Bool -> Model -> Text+emitUniqueQueryFn withInclude model =+  let name = uniqueQueryName model+      result =+        if withInclude+          then name <> " () OmitSelect"+          else name <> " OmitSelect"+      fields =+        ["include_ = ()" | withInclude]+          ++ ["select_ = OmitSelect", "where_ = key"]+   in T.unlines+        [ "uniqueQuery :: " <> uniqueTypeName model <> " -> " <> result,+          "uniqueQuery key =",+          "  " <> name <> " {" <> T.intercalate ", " fields <> "}"+        ]++emitIncludeFindManyClass :: Model -> Text+emitIncludeFindManyClass model =+  let query = queryTypeName model+      uniqueQuery = uniqueQueryName model+      result = readType model <> " include select"+   in T.unlines+        [ "class Read" <> modelName model <> " include select where",+          "  findMany :: " <> query <> " include select -> Db [" <> result <> "]",+          "  findUnique :: " <> uniqueQuery <> " include select -> Db (Either ORMError (Maybe (" <> result <> ")))",+          "  findUniqueOrFail :: " <> uniqueQuery <> " include select -> Db (Either ORMError (" <> result <> "))",+          "  findFirst :: " <> query <> " include select -> Db (Maybe (" <> result <> "))",+          "  findFirstOrFail :: " <> query <> " include select -> Db (Either ORMError (" <> result <> "))"+        ]++emitIncludeFindManyInstances :: Model -> Text+emitIncludeFindManyInstances model =+  let table = tableTypeName model+      row = rowTypeName model+      query = queryTypeName model+      uq = uniqueQueryName model+      selectTy = selectTypeName model+      parseFn = parsePickedName model+      colsFn = selectColumnsFnName model+      toPicked = toWithPickedName model+      modelNm = modelName model+      includeTy = includeApplied model+      load = loadMethod model+      whereFn = uniqueWhereName model+      rootFetch modifier =+        "Ops.findMany @" <> table <> " @" <> row <> " (prepareIncludeRootQuery @" <> table <> " (" <> modifier <> "))"+   in T.unlines $+        [ "instance (" <> loadClass model <> ") => Read" <> modelNm <> " (" <> includeTy <> ") OmitSelect where",+          "  findMany " <> query <> " {include_, where_, orderBy_, limit_, offset_} = do",+          "    roots <- " <> rootFetch "applyQueryModifiers where_ orderBy_ limit_ offset_",+          "    " <> load <> " include_ roots"+        ]+          ++ emitFindUniqueByRowsLines+            whereFn+            (uq <> " {where_, include_}")+            [ "roots <- " <> rootFetch "matching w",+              "rows <- " <> load <> " include_ roots"+            ]+          ++ emitFindUniqueOrFailLines+          ++ emitLoadedFindFirstFor model load False+          ++ emitFindFirstOrFailLines+          ++ [ "",+               "instance Read" <> modelNm <> " () OmitSelect where",+               "  findMany " <> query <> " {where_, orderBy_, limit_, offset_} =",+               "    Ops.findMany @" <> table <> " @" <> row <> " (applyQueryModifiers where_ orderBy_ limit_ offset_)"+             ]+          ++ emitFindUniqueByRowsLines+            whereFn+            (uq <> " {where_}")+            ["rows <- Ops.findMany @" <> table <> " @" <> row <> " (matching w)"]+          ++ emitFindUniqueOrFailLines+          ++ [ "  findFirst " <> query <> " {where_, orderBy_, limit_, offset_} =",+               "    Ops.findFirst @" <> table <> " @" <> row <> " (applyQueryModifiers where_ orderBy_ limit_ offset_)"+             ]+          ++ emitFindFirstOrFailLines+          ++ [ "",+               "instance (" <> loadClass model <> ") => Read" <> modelNm <> " (" <> includeTy <> ") " <> selectTy <> " where",+               "  findMany " <> query <> " {include_, select_, where_, orderBy_, limit_, offset_} = do",+               "    roots <- " <> rootFetch "applyQueryModifiers where_ orderBy_ limit_ offset_",+               "    loaded <- " <> load <> " include_ roots",+               "    pure $ map (" <> toPicked <> " select_) loaded"+             ]+          ++ emitFindUniqueByRowsLines+            whereFn+            (uq <> " {where_, include_, select_}")+            [ "roots <- " <> rootFetch "matching w",+              "loaded <- " <> load <> " include_ roots",+              "let rows = map (" <> toPicked <> " select_) loaded"+            ]+          ++ emitFindUniqueOrFailLines+          ++ emitLoadedFindFirstFor model load True+          ++ emitFindFirstOrFailLines+          ++ [ "",+               "instance Read" <> modelNm <> " () " <> selectTy <> " where",+               "  findMany " <> query <> " {select_, where_, orderBy_, limit_, offset_} =",+               "    Ops.findManyWith",+               "      (" <> parseFn <> " select_)",+               "      (selectColumns (" <> colsFn <> " select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)"+             ]+          ++ emitFindUniqueByRowsLines+            whereFn+            (uq <> " {where_, select_}")+            [ "rows <-",+              "  Ops.findManyWith",+              "    (" <> parseFn <> " select_)",+              "    (selectColumns (" <> colsFn <> " select_) . matching w)"+            ]+          ++ emitFindUniqueOrFailLines+          ++ [ "  findFirst " <> query <> " {select_, where_, orderBy_, limit_, offset_} =",+               "    Ops.findFirstWith",+               "      (" <> parseFn <> " select_)",+               "      (selectColumns (" <> colsFn <> " select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)"+             ]+          ++ emitFindFirstOrFailLines++emitLoadedFindFirstFor :: Model -> Text -> Bool -> [Text]+emitLoadedFindFirstFor model load picked =+  [ "  findFirst " <> query <> " {" <> T.intercalate ", " fields <> "} = do",+    "    roots <- Ops.findMany @" <> table <> " @" <> row <> " (prepareIncludeRootQuery @" <> table <> " (applyQueryModifiers where_ orderBy_ (Just 1) offset_))",+    "    loaded <- " <> load <> " include_ roots",+    "    pure $ case loaded of",+    "      [] -> Nothing",+    "      (row : _) -> Just " <> value+  ]+  where+    query = queryTypeName model+    table = tableTypeName model+    row = rowTypeName model+    fields = (["select_" | picked]) ++ ["include_", "where_", "orderBy_", "offset_"]+    value =+      if picked+        then "(" <> toWithPickedName model <> " select_ row)"+        else "row"++queryTypeName :: Model -> Text+queryTypeName model = modelName model <> "Query"++schemaModule :: Text -> Model -> Text+schemaModule clientModule model =+  clientSchemaPrefix clientModule <> modelName model++includeModule :: Text -> Model -> Text+includeModule clientModule model =+  clientSchemaPrefix clientModule <> "Include." <> modelName model++paramsOf :: Model -> Text+paramsOf model = T.unwords (map relName (modelRelations model))++includeType :: Model -> Text+includeType model = modelName model <> "Include"++includeApplied :: Model -> Text+includeApplied model = includeType model <> " " <> paramsOf model++withPickedType :: Model -> Text+withPickedType model = modelName model <> "WithPicked"++readType :: Model -> Text+readType model = modelName model <> "Read"++loadClass :: Model -> Text+loadClass model = "Load" <> modelName model <> " " <> paramsOf model++loadMethod :: Model -> Text+loadMethod model = "load" <> modelName model++toWithPickedName :: Model -> Text+toWithPickedName model = "to" <> withPickedType model++data EmittedUnique = EmittedUnique+  { emittedCtor :: Text,+    emittedKeyCtor :: Text,+    emittedFields :: [FieldSpec]+  }++modelUniqueKeys :: Schema -> Model -> [EmittedUnique]+modelUniqueKeys schema model =+  emittedFrom (upperFirst (fieldName primary)) [primary]+    : map fromConstraint (lookupUniques schema (modelName model))+  where+    primary = primaryKeyField model+    fromConstraint constraint =+      let fields = map (lookupField model) (uniqueFields constraint)+       in emittedFrom (T.concat (map (upperFirst . fieldName) fields)) fields+    emittedFrom label fields =+      EmittedUnique+        { emittedCtor = "By" <> label,+          emittedKeyCtor = "On" <> label,+          emittedFields = fields+        }++uniqueTypeName :: Model -> Text+uniqueTypeName model = modelName model <> "Unique"++uniqueQueryName :: Model -> Text+uniqueQueryName model = modelName model <> "UniqueQuery"++uniqueKeyTypeName :: Model -> Text+uniqueKeyTypeName model = modelName model <> "UniqueKey"++uniqueWhereName :: Model -> Text+uniqueWhereName model = lowerFirst (modelName model) <> "UniqueWhere"++uniqueConflictName :: Model -> Text+uniqueConflictName model = lowerFirst (modelName model) <> "ConflictCols"++uniqueFieldImportList :: Schema -> Model -> Text+uniqueFieldImportList schema model =+  T.intercalate ", " $+    nub+      [ fieldBinder model spec+        | key <- modelUniqueKeys schema model,+          spec <- emittedFields key+      ]++valueImportsBlock :: Schema -> Text -> Model -> Text+valueImportsBlock schema moduleName model =+  T.intercalate "\n" (valueImportLines schema moduleName model)++valueImportLines :: Schema -> Text -> Model -> [Text]+valueImportLines schema moduleName model =+  nub $+    "import Data.Text (Text)"+      : concatMap (valueImport schema moduleName) (concatMap emittedFields (modelUniqueKeys schema model))++extraValueImports :: Text -> Schema -> Model -> [Text]+extraValueImports moduleName schema model =+  filter (`notElem` nestedPreludeImports schema model) $+    nub $+      valueImportLines schema moduleName model+        ++ rootFieldImports+        ++ concat+          [ concatMap (valueImport schema moduleName) nonEnumFields+            | (rel, child) <- nestedWriteRelations schema model,+              let nonEnumFields =+                    [ f+                      | f <- modelFields child ++ [f' | f' <- modelFields child, fieldName f' /= relForeignField rel],+                        case fieldType f of+                          TyEnum _ -> False+                          _ -> True+                    ]+          ]+  where+    -- Nested-write Clients re-emit root Create/Update, so root scalar types+    -- must be in scope here (not only on Schema.<Model>).+    rootFieldImports+      | nestedWriteUsesTransaction schema model =+          concatMap (valueImport schema moduleName) (modelFields model)+      | otherwise = []++-- | True when nested create/update payloads mention 'NullableValue'.+needsNestedNullableValue :: Schema -> Model -> Bool+needsNestedNullableValue schema root =+  any fieldNullable (modelFields root)+    || any (any fieldNullable . modelFields . snd) (nestedWriteRelations schema root)++valueImport :: Schema -> Text -> FieldSpec -> [Text]+valueImport schema moduleName spec =+  case fieldType spec of+    TyText -> []+    TyUuid -> ["import Data.UUID (UUID)"]+    TyNumeric -> ["import Data.Scientific (Scientific)"]+    TyJsonb -> ["import Data.Aeson (Value)"]+    TyTimestamptz -> ["import Data.Time (UTCTime)"]+    TyInt -> []+    TyBool -> []+    TyEnum name ->+      [ enumImportLine (clientSchemaPrefix moduleName) enumSpec+        | enumSpec <- schemaEnums schema,+          enumName enumSpec == name+      ]++emitUniqueDecls :: Schema -> Model -> Text+emitUniqueDecls schema model =+  let keys = modelUniqueKeys schema model+   in T.unlines $+        emitSum (uniqueTypeName model) (map ctorLine keys)+          ++ [""]+          ++ emitSum (uniqueKeyTypeName model) (map emittedKeyCtor keys)+          ++ [""]+          ++ emitUniqueWhere model keys+          ++ [""]+          ++ emitConflictCols model keys+  where+    ctorLine key = emittedCtor key <> " " <> T.unwords (map emittedArgType (emittedFields key))++emitSum :: Text -> [Text] -> [Text]+emitSum name alts =+  ["data " <> name]+    ++ zipWith arm [0 :: Int ..] alts+    ++ ["  deriving (Eq, Show)"]+  where+    arm 0 alt = "  = " <> alt+    arm _ alt = "  | " <> alt++emitUniqueWhere :: Model -> [EmittedUnique] -> [Text]+emitUniqueWhere model keys =+  let fn = uniqueWhereName model+   in [ fn <> " :: " <> uniqueTypeName model <> " -> Where " <> tableTypeName model,+        fn <> " = \\case"+      ]+        ++ map arm keys+  where+    arm key =+      let binders = zipWith (\i _ -> "v" <> T.pack (show i)) [1 :: Int ..] (emittedFields key)+          preds =+            zipWith+              (\spec binder -> "eq " <> fieldBinder model spec <> " " <> binder)+              (emittedFields key)+              binders+       in "  "+            <> emittedCtor key+            <> " "+            <> T.unwords binders+            <> " -> "+            <> T.intercalate " `and_` " preds++emitConflictCols :: Model -> [EmittedUnique] -> [Text]+emitConflictCols model keys =+  let fn = uniqueConflictName model+   in [ fn <> " :: " <> uniqueKeyTypeName model <> " -> [Text]",+        fn <> " = \\case"+      ]+        ++ map arm keys+  where+    arm key =+      "  "+        <> emittedKeyCtor key+        <> " -> "+        <> listLit (map fieldColumn (emittedFields key))++listLit :: [Text] -> Text+listLit cols =+  "[" <> T.intercalate ", " ["\"" <> col <> "\"" | col <- cols] <> "]"++emittedArgType :: FieldSpec -> Text+emittedArgType spec =+  let base = hsType (fieldType spec)+   in if fieldNullable spec then "(Maybe " <> base <> ")" else base
+ src/Poppy/Codegen/Emit/Include.hs view
@@ -0,0 +1,656 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Emit.Include+  ( emitIncludeModule,+  )+where++import Data.List (nubBy)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.EmitCommon+  ( fieldBinder,+    pickedTypeName,+    primaryKeyField,+    rowTypeName,+    selectTypeName,+    tableTypeName,+    toPickedName,+  )+import Poppy.Codegen.IR+import Poppy.Codegen.Lookup (lookupField, lookupModel)+import Poppy.Codegen.TextUtil (lowerFirst, upperFirst)++emitIncludeModule :: Text -> Schema -> Model -> Text+emitIncludeModule moduleName schema model+  | modelName model /= modelName (representative schema model) =+      emitReexport moduleName schema model+  | otherwise =+      emitComponent moduleName schema (componentModels schema model)++emitReexport :: Text -> Schema -> Model -> Text+emitReexport moduleName schema model =+  T.unlines $+    [ "module " <> moduleName+    ]+      ++ exportLines (modelExportNames model)+      ++ [ "where",+           "",+           "import " <> repModule <> " (" <> T.intercalate ", " (modelExportNames model) <> ")"+         ]+  where+    rep = representative schema model+    repModule = includeModuleName (modulePrefix moduleName model) rep++emitComponent :: Text -> Schema -> [Model] -> Text+emitComponent moduleName schema models =+  T.unlines $+    [ "{-# 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 " <> moduleName+    ]+      ++ exportLines (concatMap modelExportNames models)+      ++ ["where", ""]+      ++ emitImports moduleName schema models+      ++ [""]+      ++ concatMap (\model -> emitModelTypes schema model ++ [""]) models+      ++ concatMap (\model -> emitModelLoad schema model ++ [""]) models++emitImports :: Text -> Schema -> [Model] -> [Text]+emitImports moduleName schema models =+  [generatedImport schema models]+    ++ concatMap (emitSchemaImport prefix models childNames) (importModels schema models)+    ++ map (emitIncludeImport prefix) (externalChildren schema models)+  where+    prefix = modulePrefix moduleName (head models)+    childNames =+      [ modelName (childModel schema rel)+        | model <- models,+          rel <- modelRelations model+      ]++generatedImport :: Schema -> [Model] -> Text+generatedImport schema models =+  "import Poppy.Internal.Generated\n  ( "+    <> T.intercalate ",\n    " names+    <> "\n  )"+  where+    rels = concatMap modelRelations models+    requireRelatedNeeded =+      any (any (isRequiredBelongsTo schema) . modelRelations) models+    names =+      [ "Db",+        "IncludeFor",+        "Load (..)",+        "Skip (..)",+        "Skipped",+        "ValidEdge",+        "skipped",+        "OmitSelect (..)"+      ]+        ++ ["requireRelated" | requireRelatedNeeded]+        ++ ["findByIn" | not (null rels)]+        ++ ["indexByPk" | any (\rel -> relKind rel == RelBelongsTo) rels]+        ++ ["indexHasMany" | any (isPlainHasMany schema) rels]+        ++ ["indexHasManyMaybe" | any (isNullableHasMany schema) rels]+        ++ ["lookupByPk" | any (\rel -> relKind rel == RelBelongsTo) rels]+        ++ ["lookupGroups" | any (\rel -> relKind rel == RelHasMany) rels]++emitSchemaImport :: Text -> [Model] -> [Text] -> Model -> [Text]+emitSchemaImport prefix component childNames model =+  [ "import qualified " <> modName <> " as " <> modelName model+    | isChild+  ]+    ++ [ "import " <> modName <> " (" <> T.intercalate ", " names <> ")"+         | not (null names)+       ]+  where+    modName = prefix <> modelName model+    inComponent = modelName model `elem` map modelName component+    isChild = modelName model `elem` childNames+    names =+      concat+        [ [pickedTypeName model | inComponent],+          [rowTypeName model <> " (..)"],+          [selectTypeName model | inComponent],+          [tableTypeName model | isChild],+          [toPickedName model | inComponent]+        ]++emitIncludeImport :: Text -> Model -> Text+emitIncludeImport prefix child =+  "import "+    <> includeModuleName prefix child+    <> " ("+    <> T.intercalate ", " names+    <> ")"+  where+    names =+      [ modelName child <> "Include (..)",+        modelName child <> "Result",+        modelName child <> "With (..)",+        "Load" <> modelName child <> " (..)"+      ]++emitModelTypes :: Schema -> Model -> [Text]+emitModelTypes schema model =+  concat+    [ emitIncludeData model,+      [""],+      emitWithData model False,+      [""],+      emitWithData model True,+      [""],+      emitToPicked model,+      [""],+      concatMap (\rel -> emitEdgeFamily schema model rel ++ [""]) (modelRelations model),+      emitResultFamily model,+      [""],+      emitReadFamily model+    ]++emitIncludeData :: Model -> [Text]+emitIncludeData model =+  [ "data " <> includeType model <> " " <> params model <> " = " <> includeType model,+    "  { " <> T.intercalate ",\n    " [relName rel <> " :: " <> relName rel | rel <- modelRelations model],+    "  }",+    "  deriving (Show, Eq)"+  ]++emitWithData :: Model -> Bool -> [Text]+emitWithData model picked =+  [ "data " <> withName <> " " <> params model <> " = " <> withName,+    "  { " <> T.intercalate ",\n    " fields,+    "  }",+    "",+    "deriving instance (" <> ctx "Eq" <> ") => Eq (" <> applied <> ")",+    "deriving instance (" <> ctx "Show" <> ") => Show (" <> applied <> ")"+  ]+  where+    withName = if picked then withPickedType model else withType model+    rootTy = if picked then pickedTypeName model else rowTypeName model+    applied = withName <> " " <> params model+    fields =+      (rootVar model <> " :: " <> rootTy)+        : [ relName rel <> " :: " <> edgeFamily model rel <> " " <> relName rel+            | rel <- modelRelations model+          ]+    ctx cls =+      T.intercalate+        ", "+        ( (cls <> " " <> rootTy)+            : [ cls <> " (" <> edgeFamily model rel <> " " <> relName rel <> ")"+                | rel <- modelRelations model+              ]+        )++emitToPicked :: Model -> [Text]+emitToPicked model =+  [ toWithPickedName model+      <> " :: "+      <> selectTypeName model+      <> " -> "+      <> withType model+      <> " "+      <> params model+      <> " -> "+      <> withPickedType model+      <> " "+      <> params model,+    toWithPickedName model <> " select_ nested =",+    "  " <> withPickedType model,+    "    { " <> T.intercalate ",\n      " fields,+    "    }"+  ]+  where+    fields =+      (rootVar model <> " = " <> toPickedName model <> " select_ nested." <> rootVar model)+        : [relName rel <> " = nested." <> relName rel | rel <- modelRelations model]++emitEdgeFamily :: Schema -> Model -> RelationSpec -> [Text]+emitEdgeFamily schema model rel =+  [ "type family " <> fam <> " edge where",+    "  " <> fam <> " Skip = Skipped \"" <> relName rel <> "\" " <> skipTy,+    "  " <> fam <> " " <> loadPat <> " = " <> loadedTy+  ]+  where+    fam = edgeFamily model rel+    child = childModel schema rel+    skipTy = wrapSkip (plainLoaded schema rel)+    (loadPat, loadedTy)+      | hasInclude child =+          ("(Load " <> tableTypeName child <> " include)", loadedRhs schema rel "include")+      | otherwise =+          ("(Load " <> tableTypeName child <> " ())", loadedRhs schema rel "")++emitResultFamily :: Model -> [Text]+emitResultFamily model =+  [ "type family " <> modelName model <> "Result include where",+    "  " <> modelName model <> "Result () = " <> rowTypeName model,+    "  "+      <> modelName model+      <> "Result ("+      <> includeType model+      <> " "+      <> params model+      <> ") = "+      <> withType model+      <> " "+      <> params model+  ]++emitReadFamily :: Model -> [Text]+emitReadFamily model =+  [ "type family " <> modelName model <> "Read include select where",+    "  " <> modelName model <> "Read () OmitSelect = " <> rowTypeName model,+    "  " <> modelName model <> "Read () " <> selectTypeName model <> " = " <> pickedTypeName model,+    "  "+      <> modelName model+      <> "Read ("+      <> includeType model+      <> " "+      <> params model+      <> ") OmitSelect = "+      <> withType model+      <> " "+      <> params model,+    "  "+      <> modelName model+      <> "Read ("+      <> includeType model+      <> " "+      <> params model+      <> ") "+      <> selectTypeName model+      <> " = "+      <> withPickedType model+      <> " "+      <> params model+  ]++emitModelLoad :: Schema -> Model -> [Text]+emitModelLoad schema model =+  concatMap (\rel -> emitEdgeLoad schema model rel ++ [""]) (modelRelations model)+    ++ emitModelLoadClass model+    ++ [""]+    ++ emitIncludeFor model++emitEdgeLoad :: Schema -> Model -> RelationSpec -> [Text]+emitEdgeLoad schema model rel =+  emitEdgeClass model rel+    ++ [""]+    ++ emitSkipInstance model rel+    ++ [""]+    ++ emitUnitInstance schema model rel+    ++ nested+    ++ [""]+    ++ emitRejectedInstance model rel+  where+    child = childModel schema rel+    nested+      | hasInclude child = "" : emitNestedInstance schema model rel child+      | otherwise = []++emitEdgeClass :: Model -> RelationSpec -> [Text]+emitEdgeClass model rel =+  [ "class " <> edgeClass model rel <> " edge where",+    "  "+      <> edgeMethod model rel+      <> " :: edge -> ["+      <> rowTypeName model+      <> "] -> Db ["+      <> edgeFamily model rel+      <> " edge]"+  ]++emitSkipInstance :: Model -> RelationSpec -> [Text]+emitSkipInstance model rel =+  [ "instance " <> edgeClass model rel <> " Skip where",+    "  " <> edgeMethod model rel <> " Skip roots = pure (map (const skipped) roots)"+  ]++emitUnitInstance :: Schema -> Model -> RelationSpec -> [Text]+emitUnitInstance schema model rel =+  [ "instance " <> edgeClass model rel <> " (Load " <> tableTypeName child <> " ()) where",+    "  " <> edgeMethod model rel <> " edge roots = do"+  ]+    ++ emitFetch schema model rel+    ++ emitGroup schema model rel False+  where+    child = childModel schema rel++emitNestedInstance :: Schema -> Model -> RelationSpec -> Model -> [Text]+emitNestedInstance schema model rel child =+  [ "instance (" <> loadClass child <> " " <> params child <> ") => " <> edgeClass model rel <> " (Load " <> tableTypeName child <> " (" <> includeType child <> " " <> params child <> ")) where",+    "  " <> edgeMethod model rel <> " edge roots = do"+  ]+    ++ emitFetch schema model rel+    ++ ["    loaded <- " <> loadMethod child <> " edge.include_ rows"]+    ++ emitGroup schema model rel True++emitRejectedInstance :: Model -> RelationSpec -> [Text]+emitRejectedInstance model rel =+  [ "instance {-# OVERLAPPABLE #-} (ValidEdge \"" <> relToModel rel <> "\" edge) => " <> edgeClass model rel <> " edge where",+    "  " <> edgeMethod model rel <> " _ roots = pure (map (const skipped) roots)"+  ]++emitFetch :: Schema -> Model -> RelationSpec -> [Text]+emitFetch schema model rel =+  case relKind rel of+    RelHasMany ->+      [ "    rows <- findByIn @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> fkBinder <> " (map (." <> parentPk <> ") roots) edge.where_ edge.orderBy_ edge.take_"+      ]+    RelBelongsTo+      | isNullableBelongsTo schema rel ->+          [ "    let keys = [key | root <- roots, Just key <- [root." <> fkName <> "]]",+            "    rows <- findByIn @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> pkBinder <> " keys edge.where_ edge.orderBy_ edge.take_"+          ]+      | otherwise ->+          [ "    rows <- findByIn @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> pkBinder <> " (map (." <> fkName <> ") roots) edge.where_ edge.orderBy_ edge.take_"+          ]+  where+    child = childModel schema rel+    parentPk = fieldName (primaryKeyField model)+    fkName = relForeignField rel+    fkField = lookupField child (relForeignField rel)+    fkBinder = modelName child <> "." <> fieldBinder child fkField+    pkField = lookupField child (relLocalField rel)+    pkBinder = modelName child <> "." <> fieldBinder child pkField++emitGroup :: Schema -> Model -> RelationSpec -> Bool -> [Text]+emitGroup schema model rel nested =+  case relKind rel of+    RelHasMany ->+      [ "    let grouped = " <> indexFn <> " " <> keyExpr <> " " <> source,+        "    pure [lookupGroups root." <> parentPk <> " grouped | root <- roots]"+      ]+    RelBelongsTo+      | isNullableBelongsTo schema rel ->+          [ "    let indexed = indexByPk " <> keyExpr <> " " <> source,+            "    pure [root." <> fkName <> " >>= \\key -> lookupByPk key indexed | root <- roots]"+          ]+      | otherwise ->+          [ "    let indexed = indexByPk " <> keyExpr <> " " <> source,+            "    pure [requireRelated \"" <> relName rel <> "\" (lookupByPk root." <> fkName <> " indexed) | root <- roots]"+          ]+  where+    child = childModel schema rel+    parentPk = fieldName (primaryKeyField model)+    fkName = relForeignField rel+    source = if nested then "loaded" else "rows"+    indexFn+      | isNullableHasMany schema rel = "indexHasManyMaybe"+      | otherwise = "indexHasMany"+    keyExpr+      | nested && relKind rel == RelHasMany =+          keyOn (childFkName schema rel) (lowerFirst (modelName child))+      | nested =+          keyOn (fieldName (primaryKeyField child)) (lowerFirst (modelName child))+      | relKind rel == RelHasMany =+          "(." <> childFkName schema rel <> ")"+      | otherwise =+          "(." <> fieldName (primaryKeyField child) <> ")"++emitModelLoadClass :: Model -> [Text]+emitModelLoadClass model =+  [ "class " <> loadClass model <> " " <> params model <> " where",+    "  "+      <> loadMethod model+      <> " :: "+      <> includeType model+      <> " "+      <> params model+      <> " -> ["+      <> rowTypeName model+      <> "] -> Db ["+      <> withType model+      <> " "+      <> params model+      <> "]",+    "",+    "instance (" <> T.intercalate ", " constraints <> ") => " <> loadClass model <> " " <> params model <> " where",+    "  " <> loadMethod model <> " include roots = do"+  ]+    ++ concatMap edgeBind (modelRelations model)+    ++ [ "    pure",+         "      [ " <> withType model,+         "          { " <> T.intercalate ",\n            " fields,+         "          }",+         "      | (n, root) <- zip [0 :: Int ..] roots",+         "      ]"+       ]+  where+    constraints =+      [edgeClass model rel <> " " <> relName rel | rel <- modelRelations model]+        ++ [validEdge model rel | rel <- modelRelations model]+    edgeBind rel =+      [ "    "+          <> relName rel+          <> "Loaded <- "+          <> edgeMethod model rel+          <> " include."+          <> relName rel+          <> " roots"+      ]+    fields =+      (rootVar model <> " = root")+        : [relName rel <> " = " <> relName rel <> "Loaded !! n" | rel <- modelRelations model]++emitIncludeFor :: Model -> [Text]+emitIncludeFor model =+  [ "instance (" <> T.intercalate ", " [validEdge model rel | rel <- modelRelations model] <> ") => IncludeFor \"" <> modelName model <> "\" (" <> includeType model <> " " <> params model <> ")"+  ]++validEdge :: Model -> RelationSpec -> Text+validEdge _model rel =+  "ValidEdge \"" <> relToModel rel <> "\" " <> relName rel++childModel :: Schema -> RelationSpec -> Model+childModel schema rel = lookupModel schema (relToModel rel)++hasInclude :: Model -> Bool+hasInclude model = not (null (modelRelations model))++isRequiredBelongsTo :: Schema -> RelationSpec -> Bool+isRequiredBelongsTo schema rel =+  relKind rel == RelBelongsTo && not (fieldNullable (lookupField (lookupModel schema (relFromModel rel)) (relForeignField rel)))++isNullableBelongsTo :: Schema -> RelationSpec -> Bool+isNullableBelongsTo schema rel =+  relKind rel == RelBelongsTo && not (isRequiredBelongsTo schema rel)++isNullableHasMany :: Schema -> RelationSpec -> Bool+isNullableHasMany schema rel =+  relKind rel == RelHasMany && fieldNullable (lookupField (childModel schema rel) (relForeignField rel))++isPlainHasMany :: Schema -> RelationSpec -> Bool+isPlainHasMany schema rel =+  relKind rel == RelHasMany && not (isNullableHasMany schema rel)++plainLoaded :: Schema -> RelationSpec -> Text+plainLoaded schema rel =+  case relKind rel of+    RelHasMany -> "[" <> rowTypeName child <> "]"+    RelBelongsTo+      | isNullableBelongsTo schema rel -> "Maybe " <> rowTypeName child+      | otherwise -> rowTypeName child+  where+    child = childModel schema rel++wrapSkip :: Text -> Text+wrapSkip ty+  | " " `T.isInfixOf` ty = "(" <> ty <> ")"+  | otherwise = ty++loadedRhs :: Schema -> RelationSpec -> Text -> Text+loadedRhs schema rel includeVar =+  case relKind rel of+    RelHasMany -> "[" <> childTy <> "]"+    RelBelongsTo+      | isNullableBelongsTo schema rel -> "Maybe (" <> childTy <> ")"+      | otherwise -> childTy+  where+    child = childModel schema rel+    childTy+      | hasInclude child = modelName child <> "Result" <> includeArg+      | otherwise = rowTypeName child+    includeArg+      | T.null includeVar = ""+      | otherwise = " " <> includeVar++childFkName :: Schema -> RelationSpec -> Text+childFkName schema rel =+  fieldName (lookupField (childModel schema rel) (relForeignField rel))++keyOn :: Text -> Text -> Text+keyOn keyField accessor = "((." <> keyField <> ") . (." <> accessor <> "))"++params :: Model -> Text+params model = T.unwords (map relName (modelRelations model))++includeType :: Model -> Text+includeType model = modelName model <> "Include"++withType :: Model -> Text+withType model = modelName model <> "With"++withPickedType :: Model -> Text+withPickedType model = modelName model <> "WithPicked"++edgeFamily :: Model -> RelationSpec -> Text+edgeFamily model rel = modelName model <> upperFirst (relName rel)++edgeClass :: Model -> RelationSpec -> Text+edgeClass model rel = "Load" <> edgeFamily model rel++edgeMethod :: Model -> RelationSpec -> Text+edgeMethod model rel = "load" <> edgeFamily model rel++loadClass :: Model -> Text+loadClass model = "Load" <> modelName model++loadMethod :: Model -> Text+loadMethod model = "load" <> modelName model++toWithPickedName :: Model -> Text+toWithPickedName model = "to" <> withPickedType model++rootVar :: Model -> Text+rootVar model = lowerFirst (modelName model)++modelExportNames :: Model -> [Text]+modelExportNames model =+  [ includeType model <> " (..)",+    withType model <> " (..)",+    withPickedType model <> " (..)"+  ]+    ++ [edgeFamily model rel | rel <- modelRelations model]+    ++ [ modelName model <> "Result",+         modelName model <> "Read",+         loadClass model <> " (..)",+         toWithPickedName model+       ]++exportLines :: [Text] -> [Text]+exportLines [] = ["  ()"]+exportLines (first : rest) =+  ("  ( " <> first) : map ("  , " <>) rest ++ ["  )"]++includeModels :: Schema -> [Model]+includeModels schema = filter hasInclude (schemaModels schema)++componentModels :: Schema -> Model -> [Model]+componentModels schema model =+  [m | m <- includeModels schema, modelName m `elem` componentNames]+  where+    componentNames =+      head+        [ names+          | names <- stronglyConnected (map modelName (includeModels schema)) (neighborNames schema),+            modelName model `elem` names+        ]++representative :: Schema -> Model -> Model+representative schema model = head (componentModels schema model)++neighborNames :: Schema -> Text -> [Text]+neighborNames schema name =+  map modelName (deps schema (lookupModel schema name))++deps :: Schema -> Model -> [Model]+deps schema model =+  nubBy (\a b -> modelName a == modelName b) $+    [ child+      | rel <- modelRelations model,+        let child = childModel schema rel,+        modelName child /= modelName model,+        hasInclude child+    ]++importModels :: Schema -> [Model] -> [Model]+importModels schema models =+  nubBy (\a b -> modelName a == modelName b) $+    models ++ concatMap (map (childModel schema) . modelRelations) models++externalChildren :: Schema -> [Model] -> [Model]+externalChildren schema models =+  nubBy (\a b -> modelName a == modelName b) $+    [ child+      | model <- models,+        rel <- modelRelations model,+        let child = childModel schema rel,+        hasInclude child,+        modelName child `notElem` map modelName models+    ]++modulePrefix :: Text -> Model -> Text+modulePrefix moduleName model =+  fromMaybe+    "Schema."+    (T.stripSuffix ("Include." <> modelName model) moduleName)++includeModuleName :: Text -> Model -> Text+includeModuleName prefix model = prefix <> "Include." <> modelName model++stronglyConnected :: [Text] -> (Text -> [Text]) -> [[Text]]+stronglyConnected nodes neighbors =+  let (_, finish) = dfs neighbors [] [] nodes+   in walk (transpose nodes neighbors) [] [] finish++dfs :: (Text -> [Text]) -> [Text] -> [Text] -> [Text] -> ([Text], [Text])+dfs _ seen order [] = (seen, order)+dfs neighbors seen order (name : rest)+  | name `elem` seen = dfs neighbors seen order rest+  | otherwise =+      let (seen1, order1) = dfs neighbors (name : seen) order (neighbors name)+       in dfs neighbors seen1 (name : order1) rest++walk :: (Text -> [Text]) -> [Text] -> [[Text]] -> [Text] -> [[Text]]+walk _ _ comps [] = comps+walk incoming seen comps (name : rest)+  | name `elem` seen = walk incoming seen comps rest+  | otherwise =+      let (members, seen1) = collect incoming [] (name : seen) [name]+       in walk incoming seen1 (members : comps) rest++collect :: (Text -> [Text]) -> [Text] -> [Text] -> [Text] -> ([Text], [Text])+collect _ acc seen [] = (acc, seen)+collect incoming acc seen (name : stack) =+  let more = [next | next <- incoming name, next `notElem` seen]+   in collect incoming (name : acc) (more ++ seen) (more ++ stack)++transpose :: [Text] -> (Text -> [Text]) -> Text -> [Text]+transpose nodes neighbors name =+  [other | other <- nodes, name `elem` neighbors other]
+ src/Poppy/Codegen/Emit/NestedWrite.hs view
@@ -0,0 +1,743 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Emit.NestedWrite+  ( nestedWriteRelations,+    nestedWriteExportItems,+    emitNestedWriteTypes,+    emitNestedWriteHelpers,+    emitCreateFn,+    emitClientCreateManyFn,+    emitUpdateFn,+    emitUpdateManyFn,+    emitClientUpsertFn,+    nestedChildSchemaImports,+    nestedChildClientImports,+    nestedChildEnumImports,+    nestedWriteUsesTransaction,+    schemaModuleAlias,+    childHasForeignKey,+  )+where++import Data.List (nub, nubBy)+import Data.Maybe (isNothing)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.EmitCommon+import Poppy.Codegen.IR+import Poppy.Codegen.Lookup (lookupField, lookupModel)+import Poppy.Codegen.TextUtil (lowerFirst, upperFirst)++type NestedRel = (RelationSpec, Model)++nestedWriteRelations :: Schema -> Model -> [NestedRel]+nestedWriteRelations schema root =+  [ (rel, lookupModel schema (relToModel rel))+    | rel <- modelRelations root,+      relKind rel == RelHasMany,+      childHasForeignKey schema rel+  ]++childHasForeignKey :: Schema -> RelationSpec -> Bool+childHasForeignKey schema rel =+  any+    ((== relForeignField rel) . fieldName)+    (modelFields (lookupModel schema (relToModel rel)))++nestedWriteUsesTransaction :: Schema -> Model -> Bool+nestedWriteUsesTransaction schema model =+  not (null (nestedWriteRelations schema model))++schemaModuleAlias :: Model -> Text+schemaModuleAlias model = modelName model <> "Schema"++nestedWriteExportItems :: Schema -> Model -> [Text]+nestedWriteExportItems schema root =+  nub $+    case nestedWriteRelations schema root of+      [] -> []+      rels ->+        [ createTypeName root <> "Scalars,",+          updateTypeName root <> "Scalars,"+        ]+          ++ concat+            [ [ nestedCreateTypeName rels rel child <> " (..),",+                nestedUpsertTypeName child <> " (..),",+                nestedUpdateTypeName rel <> " (..),",+                emptyNestedUpdateName rel <> ","+              ]+              | (rel, child) <- rels+            ]++uniqueByCreateType :: [NestedRel] -> [NestedRel]+uniqueByCreateType rels =+  nubBy+    ( \(r1, c1) (r2, c2) ->+        nestedCreateTypeName rels r1 c1 == nestedCreateTypeName rels r2 c2+    )+    rels++uniqueByChild :: [NestedRel] -> [NestedRel]+uniqueByChild =+  nubBy (\(_, a) (_, b) -> modelName a == modelName b)++nestedCreateTypeName :: [NestedRel] -> RelationSpec -> Model -> Text+nestedCreateTypeName rels rel child =+  if length (nub [relForeignField r | (r, c) <- rels, modelName c == modelName child]) > 1+    then upperFirst (relName rel) <> "NestedCreate"+    else modelName child <> "NestedCreate"++nestedUpsertTypeName :: Model -> Text+nestedUpsertTypeName child = modelName child <> "NestedUpsert"++nestedUpdateTypeName :: RelationSpec -> Text+nestedUpdateTypeName rel = upperFirst (relName rel) <> "Update"++emptyNestedUpdateName :: RelationSpec -> Text+emptyNestedUpdateName rel = "empty" <> nestedUpdateTypeName rel++createCtorName :: Model -> Text+createCtorName child = "Create" <> modelName child++connectCtorName :: Model -> Text+connectCtorName child = "Connect" <> modelName child++applyCreateFnName :: RelationSpec -> Text+applyCreateFnName rel = "apply" <> upperFirst (relName rel) <> "Create"++applyUpdateFnName :: RelationSpec -> Text+applyUpdateFnName rel = "apply" <> nestedUpdateTypeName rel++insertCreatesFnName :: RelationSpec -> Text+insertCreatesFnName rel = "insert" <> upperFirst (relName rel)++replaceFnName :: RelationSpec -> Text+replaceFnName rel = "replace" <> upperFirst (relName rel)++deleteFnName :: RelationSpec -> Text+deleteFnName rel = "delete" <> upperFirst (relName rel)++updateChildFnName :: RelationSpec -> Text+updateChildFnName rel = "update" <> upperFirst (relName rel) <> "Rows"++upsertFnName :: RelationSpec -> Text+upsertFnName rel = "upsert" <> upperFirst (relName rel)++connectFnName :: RelationSpec -> Text+connectFnName rel = "connect" <> upperFirst (relName rel)++disconnectFnName :: RelationSpec -> Text+disconnectFnName rel = "disconnect" <> upperFirst (relName rel)++fkField :: Model -> RelationSpec -> FieldSpec+fkField child rel = lookupField child (relForeignField rel)++nestedPayloadFields :: Model -> RelationSpec -> [FieldSpec]+nestedPayloadFields child rel =+  [f | f <- modelFields child, fieldName f /= relForeignField rel]++pkFieldName :: Model -> Text+pkFieldName model = fieldName (primaryKeyField model)++childUniqueWhereRef :: Model -> Model -> Text+childUniqueWhereRef root child+  | modelName root == modelName child = uniqueWhereName child+  | otherwise = modelName child <> "." <> uniqueWhereName child++childUniqueTypeRef :: Model -> Model -> Text+childUniqueTypeRef root child+  | modelName root == modelName child = uniqueTypeName child+  | otherwise = modelName child <> "." <> uniqueTypeName child++childCreateTypeRef :: Model -> Model -> Text+childCreateTypeRef root child+  | modelName root == modelName child = schemaModuleAlias root <> "." <> createTypeName child+  | otherwise = createTypeName child++childUpdateTypeRef :: Model -> Model -> Text+childUpdateTypeRef root child+  | modelName root == modelName child = schemaModuleAlias root <> "." <> updateTypeName child+  | otherwise = updateTypeName child++toScalarsName :: Model -> Text+toScalarsName model = "to" <> createTypeName model <> "Scalars"++toUpdateScalarsName :: Model -> Text+toUpdateScalarsName model = "to" <> updateTypeName model <> "Scalars"++hasCreateNestedName :: Model -> Text+hasCreateNestedName model = "has" <> modelName model <> "NestedCreate"++hasUpdateNestedName :: Model -> Text+hasUpdateNestedName model = "has" <> modelName model <> "NestedUpdate"++uniqueConflictName :: Model -> Text+uniqueConflictName model = lowerFirst (modelName model) <> "ConflictCols"++leaveFkValue :: FieldSpec -> Text+leaveFkValue f+  | fieldNullable f = "Omit"+  | otherwise = "Nothing"++fkAssign :: FieldSpec -> Text+fkAssign f+  | fieldNullable f = "Value parentId"+  | otherwise = "parentId"++connectFkValue :: FieldSpec -> Text+connectFkValue f+  | fieldNullable f = "Value parentId"+  | otherwise = "Just parentId"++ownsParentPred :: Model -> RelationSpec -> Text+ownsParentPred child rel =+  let fk = fieldName (fkField child rel)+   in if fieldNullable (fkField child rel)+        then "row." <> fk <> " == Just parentId"+        else "row." <> fk <> " == parentId"++emitNestedWriteTypes :: Schema -> Model -> Text+emitNestedWriteTypes schema root =+  case nestedWriteRelations schema root of+    [] -> ""+    rels ->+      T.unlines $+        map+          T.strip+          ( map (emitNestedCreateType root rels) (uniqueByCreateType rels)+              ++ map (emitNestedUpsertType root rels) (uniqueByChild rels)+              ++ map (emitNestedUpdateType root rels) rels+              ++ [emitRootCreateType root rels, emitRootUpdateType root rels]+          )++emitNestedCreateType :: Model -> [NestedRel] -> NestedRel -> Text+emitNestedCreateType root rels (rel, child) =+  T.unlines+    [ "data " <> nestedCreateTypeName rels rel child,+      "  = " <> createCtorName child,+      "      { " <> T.intercalate ", " fieldLines,+      "      }",+      "  | " <> connectCtorName child <> " " <> childUniqueTypeRef root child,+      "  deriving (Show, Eq)"+    ]+  where+    fieldLines =+      [ fieldName f <> " :: " <> createHsType f+        | f <- nestedPayloadFields child rel+      ]++emitNestedUpsertType :: Model -> [NestedRel] -> NestedRel -> Text+emitNestedUpsertType root rels (rel, child) =+  T.unlines+    [ "data " <> nestedUpsertTypeName child <> " = " <> nestedUpsertTypeName child,+      "  { where_ :: " <> childUniqueTypeRef root child,+      "  , create :: " <> nestedCreateTypeName rels rel child,+      "  , update :: " <> childUpdateTypeRef root child,+      "  }",+      "  deriving (Show, Eq)"+    ]++emitNestedUpdateType :: Model -> [NestedRel] -> NestedRel -> Text+emitNestedUpdateType root rels (rel, child) =+  let createTy = nestedCreateTypeName rels rel child+      uniqueTy = childUniqueTypeRef root child+      nullableFk = fieldNullable (fkField child rel)+   in T.unlines $+        [ "data " <> nestedUpdateTypeName rel <> " = " <> nestedUpdateTypeName rel,+          "  { replaceWith :: Maybe [" <> createTy <> "]",+          "  , create :: [" <> createTy <> "]",+          "  , createMany :: [" <> createTy <> "]",+          "  , connect :: [" <> uniqueTy <> "]",+          "  , delete :: [" <> uniqueTy <> "]",+          "  , update :: [(" <> uniqueTy <> ", " <> childUpdateTypeRef root child <> ")]",+          "  , upsert :: [" <> nestedUpsertTypeName child <> "]"+        ]+          ++ ["  , disconnect :: [" <> uniqueTy <> "]" | nullableFk]+          ++ [ "  }",+               "  deriving (Show, Eq)",+               "",+               emptyNestedUpdateName rel <> " :: " <> nestedUpdateTypeName rel,+               emptyNestedUpdateName rel <> " =",+               "  " <> nestedUpdateTypeName rel,+               "    { replaceWith = Nothing",+               "    , create = []",+               "    , createMany = []",+               "    , connect = []",+               "    , delete = []",+               "    , update = []",+               "    , upsert = []"+             ]+          ++ ["    , disconnect = []" | nullableFk]+          ++ ["    }"]++emitRootCreateType :: Model -> [NestedRel] -> Text+emitRootCreateType root rels =+  T.unlines+    [ "data " <> createTypeName root <> " = " <> createTypeName root,+      "  { " <> T.intercalate ",\n    " (scalarFields ++ relFields),+      "  }",+      "  deriving (Show, Eq)",+      "",+      "type " <> createTypeName root <> "Scalars = " <> schemaModuleAlias root <> "." <> createTypeName root,+      "",+      toScalarsName root <> " :: " <> createTypeName root <> " -> " <> createTypeName root <> "Scalars",+      toScalarsName root <> " input =",+      "  " <> schemaModuleAlias root <> "." <> createTypeName root,+      "    { " <> T.intercalate ",\n      " assignFields,+      "    }"+    ]+  where+    scalarFields = [fieldName f <> " :: " <> createHsType f | f <- modelFields root]+    relFields =+      [ relName rel <> " :: [" <> nestedCreateTypeName rels rel child <> "]"+        | (rel, child) <- rels+      ]+    assignFields = [fieldName f <> " = input." <> fieldName f | f <- modelFields root]++emitRootUpdateType :: Model -> [NestedRel] -> Text+emitRootUpdateType root rels =+  T.unlines+    [ "data " <> updateTypeName root <> " = " <> updateTypeName root,+      "  { " <> T.intercalate ",\n    " (scalarFields ++ relFields),+      "  }",+      "  deriving (Show, Eq)",+      "",+      "type " <> updateTypeName root <> "Scalars = " <> schemaModuleAlias root <> "." <> updateTypeName root,+      "",+      toUpdateScalarsName root <> " :: " <> updateTypeName root <> " -> " <> updateTypeName root <> "Scalars",+      toUpdateScalarsName root <> " input =",+      "  " <> schemaModuleAlias root <> "." <> updateTypeName root,+      "    { " <> T.intercalate ",\n      " assignFields,+      "    }"+    ]+  where+    scalarFields = [fieldName f <> " :: " <> updateHsType f | f <- updateFields root]+    relFields = [relName rel <> " :: Maybe " <> nestedUpdateTypeName rel | (rel, _) <- rels]+    assignFields = [fieldName f <> " = input." <> fieldName f | f <- updateFields root]++emitCreateFn :: Schema -> Model -> Text+emitCreateFn schema model =+  case nestedWriteRelations schema model of+    [] ->+      T.unlines+        [ "create :: " <> createTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+          "create = Insert.insert @" <> tableTypeName model <> " @" <> rowTypeName model+        ]+    rels ->+      T.unlines+        [ "create :: " <> createTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+          "create input =",+          "  if " <> hasCreateNestedName model <> " input",+          "    then transactionEither (createWithNested input)",+          "    else Insert.insert @" <> table <> " @" <> row <> " (" <> toScalarsName model <> " input)",+          "",+          hasCreateNestedName model <> " :: " <> createTypeName model <> " -> Bool",+          hasCreateNestedName model <> " input =",+          "  " <> T.intercalate " || " ["not (null input." <> relName rel <> ")" | (rel, _) <- rels],+          "",+          "createWithNested :: " <> createTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+          "createWithNested input = do",+          "  rootResult <- Insert.insert @" <> table <> " @" <> row <> " (" <> toScalarsName model <> " input)",+          "  case rootResult of",+          "    Left err -> pure (Left err)",+          "    Right row -> do",+          "      nestedResult <-",+          "        sequenceNested",+          "          [ " <> T.intercalate "\n          , " applyCalls,+          "          ]",+          "      case nestedResult of",+          "        Left err -> pure (Left err)",+          "        Right () -> pure (Right row)"+        ]+  where+    table = tableTypeName model+    row = rowTypeName model+    applyCalls =+      [ applyCreateFnName rel <> " row." <> pkFieldName model <> " input." <> relName rel+        | (rel, _) <- nestedWriteRelations schema model+      ]++emitClientCreateManyFn :: Schema -> Model -> Text+emitClientCreateManyFn schema model =+  T.unlines+    [ "createMany :: [" <> scalars <> "] -> Db (Either ORMError Int)",+      "createMany = Insert.insertMany @" <> tableTypeName model+    ]+  where+    scalars =+      if nestedWriteUsesTransaction schema model+        then createTypeName model <> "Scalars"+        else createTypeName model++emitUpdateFn :: Schema -> Model -> Text+emitUpdateFn schema model =+  case nestedWriteRelations schema model of+    [] ->+      T.unlines+        [ "update :: " <> uniqueTypeName model <> " -> " <> updateTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+          "update key input =",+          "  Update.updateWhere @" <> tableTypeName model <> " @" <> rowTypeName model <> " (" <> uniqueWhereName model <> " key) input"+        ]+    rels ->+      T.unlines+        [ "update :: " <> uniqueTypeName model <> " -> " <> updateTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+          "update key input =",+          "  if " <> hasUpdateNestedName model <> " input",+          "    then transactionEither (updateWithNested key input)",+          "    else Update.updateWhere @" <> table <> " @" <> row <> " (" <> uniqueWhereName model <> " key) (" <> toUpdateScalarsName model <> " input)",+          "",+          hasUpdateNestedName model <> " :: " <> updateTypeName model <> " -> Bool",+          hasUpdateNestedName model <> " input =",+          "  " <> T.intercalate " || " ["isJust input." <> relName rel | (rel, _) <- rels],+          "",+          "updateWithNested :: " <> uniqueTypeName model <> " -> " <> updateTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+          "updateWithNested key input = do",+          "  updateResult <- Update.updateWhere @" <> table <> " @" <> row <> " (" <> uniqueWhereName model <> " key) (" <> toUpdateScalarsName model <> " input)",+          "  case updateResult of",+          "    Left err -> pure (Left err)",+          "    Right row -> do",+          "      nestedResult <-",+          "        sequenceNested",+          "          [ " <> T.intercalate "\n          , " applyCalls,+          "          ]",+          "      case nestedResult of",+          "        Left err -> pure (Left err)",+          "        Right () -> pure (Right row)"+        ]+  where+    table = tableTypeName model+    row = rowTypeName model+    applyCalls =+      [ "maybe (pure (Right ())) (" <> applyUpdateFnName rel <> " row." <> pkFieldName model <> ") input." <> relName rel+        | (rel, _) <- nestedWriteRelations schema model+      ]++emitUpdateManyFn :: Schema -> Model -> Text+emitUpdateManyFn schema model =+  T.unlines+    [ "updateMany :: Where " <> tableTypeName model <> " -> " <> scalars <> " -> Db (Either ORMError Int)",+      "updateMany = Update.updateMany @" <> tableTypeName model+    ]+  where+    scalars =+      if nestedWriteUsesTransaction schema model+        then updateTypeName model <> "Scalars"+        else updateTypeName model++emitClientUpsertFn :: Schema -> Model -> Text+emitClientUpsertFn schema model =+  T.unlines+    [ "upsert :: " <> uniqueKeyTypeName model <> " -> " <> createTy <> " -> " <> updateTy <> " -> Db (Either ORMError " <> rowTypeName model <> ")",+      "upsert key createInput updateInput =",+      "  Insert.upsert @" <> tableTypeName model <> " @" <> rowTypeName model <> " (" <> uniqueConflictName model <> " key) createInput updateInput"+    ]+  where+    nested = nestedWriteUsesTransaction schema model+    createTy = if nested then createTypeName model <> "Scalars" else createTypeName model+    updateTy = if nested then updateTypeName model <> "Scalars" else updateTypeName model++emitNestedWriteHelpers :: Schema -> Model -> Text+emitNestedWriteHelpers schema root =+  case nestedWriteRelations schema root of+    [] -> ""+    rels ->+      T.unlines $+        map T.strip $+          emitSequenceNested : concatMap (emitRelHelpers root rels) rels++emitSequenceNested :: Text+emitSequenceNested =+  T.unlines+    [ "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"+    ]++emitRelHelpers :: Model -> [NestedRel] -> NestedRel -> [Text]+emitRelHelpers root rels nested@(rel, child) =+  [ emitApplyCreate root rels nested,+    emitApplyUpdate root nested,+    emitReplaceFn root rels nested,+    emitInsertCreateFn root rels nested,+    emitDeleteFn root nested,+    emitUpdateChildFn root nested,+    emitUpsertFn root nested,+    emitConnectFn root nested+  ]+    ++ [emitDisconnectFn root nested | fieldNullable (fkField child rel)]++emitApplyCreate :: Model -> [NestedRel] -> NestedRel -> Text+emitApplyCreate root rels (rel, child) =+  T.unlines+    [ applyCreateFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedCreateTypeName rels rel child <> "] -> Db (Either ORMError ())",+      applyCreateFnName rel <> " = " <> insertCreatesFnName rel+    ]++emitApplyUpdate :: Model -> NestedRel -> Text+emitApplyUpdate root (rel, child) =+  T.unlines $+    [ applyUpdateFnName rel <> " :: " <> pkHsType root <> " -> " <> nestedUpdateTypeName rel <> " -> Db (Either ORMError ())",+      applyUpdateFnName rel <> " parentId ops = do",+      "  replaced <- case ops.replaceWith of",+      "    Nothing -> pure (Right ())",+      "    Just items -> " <> replaceFnName rel <> " parentId items",+      "  case replaced of",+      "    Left err -> pure (Left err)",+      "    Right () ->",+      "      sequenceNested",+      "        [ " <> deleteFnName rel <> " parentId ops.delete",+      "        , " <> updateChildFnName rel <> " parentId ops.update",+      "        , " <> upsertFnName rel <> " parentId ops.upsert",+      "        , " <> insertCreatesFnName rel <> " parentId ops.create",+      "        , " <> insertCreatesFnName rel <> " parentId ops.createMany",+      "        , " <> connectFnName rel <> " parentId ops.connect"+    ]+      ++ ["        , " <> disconnectFnName rel <> " parentId ops.disconnect" | fieldNullable (fkField child rel)]+      ++ ["        ]"]++emitReplaceFn :: Model -> [NestedRel] -> NestedRel -> Text+emitReplaceFn root rels (rel, child) =+  T.unlines+    [ replaceFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedCreateTypeName rels rel child <> "] -> Db (Either ORMError ())",+      replaceFnName rel <> " parentId items = do",+      "  result <-",+      "    Delete.deleteWhere $",+      "      Delete.whereDelete (fieldColumn " <> fkBinder <> " <> \" = ?\") [toField parentId] (Delete.emptyDelete @" <> tableTypeName child <> ")",+      "  case result of",+      "    Left err -> pure (Left err)",+      "    Right _ -> " <> insertCreatesFnName rel <> " parentId items"+    ]+  where+    fkBinder = fieldBinder child (fkField child rel)++emitInsertCreateFn :: Model -> [NestedRel] -> NestedRel -> Text+emitInsertCreateFn root rels (rel, child) =+  T.unlines+    [ insertCreatesFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedCreateTypeName rels rel child <> "] -> Db (Either ORMError ())",+      insertCreatesFnName rel <> " parentId = go",+      "  where",+      "    go [] = pure (Right ())",+      "    go (nested : rest) = do",+      "      result <- case nested of",+      "        " <> connectCtorName child <> " key -> " <> connectFnName rel <> " parentId [key]",+      "        " <> createCtorName child <> " {" <> T.intercalate ", " binders <> "} -> do",+      "          inserted <- Insert.insert @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> childCreateTypeRef root child,+      "            { " <> T.intercalate ",\n              " assigns,+      "            }",+      "          pure $ case inserted of",+      "            Left err -> Left err",+      "            Right _ -> Right ()",+      "      case result of",+      "        Left err -> pure (Left err)",+      "        Right () -> go rest"+    ]+  where+    payload = nestedPayloadFields child rel+    binders = map fieldName payload+    fk = fkField child rel+    assigns =+      [fieldName f <> " = " <> fieldName f | f <- payload]+        ++ [fieldName fk <> " = " <> fkAssign fk]++emitDeleteFn :: Model -> NestedRel -> Text+emitDeleteFn root (rel, child) =+  T.unlines+    [ deleteFnName rel <> " :: " <> pkHsType root <> " -> [" <> childUniqueTypeRef root child <> "] -> Db (Either ORMError ())",+      deleteFnName rel <> " _ [] = pure (Right ())",+      deleteFnName rel <> " parentId keys = sequenceNested (map deleteOne keys)",+      "  where",+      "    deleteOne key = do",+      "      result <- Delete.deleteMany @" <> tableTypeName child,+      "        (" <> childUniqueWhereRef root child <> " key `and_` eq " <> fkBinder <> " parentId)",+      "      pure $ case result of",+      "        Left err -> Left err",+      "        Right _ -> Right ()"+    ]+  where+    fkBinder = fieldBinder child (fkField child rel)++emitUpdateChildFn :: Model -> NestedRel -> Text+emitUpdateChildFn root (rel, child) =+  T.unlines+    [ updateChildFnName rel <> " :: " <> pkHsType root <> " -> [(" <> childUniqueTypeRef root child <> ", " <> childUpdateTypeRef root child <> ")] -> Db (Either ORMError ())",+      updateChildFnName rel <> " parentId = go",+      "  where",+      "    go [] = pure (Right ())",+      "    go ((key, nested) : rest) = do",+      "      let patched = " <> leaveFkUpdateExpr root child rel "nested",+      "      result <-",+      "        Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child,+      "          (" <> childUniqueWhereRef root child <> " key `and_` eq " <> fkBinder <> " parentId)",+      "          patched",+      "      case result of",+      "        Left err -> pure (Left err)",+      "        Right _ -> go rest"+    ]+  where+    fkBinder = fieldBinder child (fkField child rel)++leaveFkUpdateExpr :: Model -> Model -> RelationSpec -> Text -> Text+leaveFkUpdateExpr root child rel source =+  childUpdateTypeRef root child+    <> " { "+    <> T.intercalate ", " fields+    <> " }"+  where+    fk = fkField child rel+    fields =+      [ if fieldName f == fieldName fk+          then fieldName f <> " = " <> leaveFkValue fk+          else fieldName f <> " = " <> source <> "." <> fieldName f+        | f <- updateFields child+      ]++emitUpsertFn :: Model -> NestedRel -> Text+emitUpsertFn root (rel, child) =+  T.unlines+    [ upsertFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedUpsertTypeName child <> "] -> Db (Either ORMError ())",+      upsertFnName rel <> " parentId = go",+      "  where",+      "    go [] = pure (Right ())",+      "    go (item : rest) = do",+      "      existing <- Ops.findMany @" <> tableTypeName child <> " @" <> rowTypeName child <> " (matching (" <> childUniqueWhereRef root child <> " item.where_))",+      "      result <- case fromUniqueRows existing of",+      "        Left err -> pure (Left err)",+      "        Right Nothing -> " <> insertCreatesFnName rel <> " parentId [item.create]",+      "        Right (Just row) ->",+      "          if " <> ownsParentPred child rel,+      "            then do",+      "              let patched = " <> leaveFkUpdateExpr root child rel "item.update",+      "              updated <-",+      "                Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child,+      "                  (" <> childUniqueWhereRef root child <> " item.where_ `and_` eq " <> fkBinder <> " 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"+    ]+  where+    fkBinder = fieldBinder child (fkField child rel)++emitConnectFn :: Model -> NestedRel -> Text+emitConnectFn root (rel, child) =+  T.unlines+    [ connectFnName rel <> " :: " <> pkHsType root <> " -> [" <> childUniqueTypeRef root child <> "] -> Db (Either ORMError ())",+      connectFnName rel <> " _ [] = pure (Right ())",+      connectFnName rel <> " parentId keys = sequenceNested (map connectOne keys)",+      "  where",+      "    connectOne key = do",+      "      result <-",+      "        Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child,+      "          (" <> childUniqueWhereRef root child <> " key)",+      "          (" <> childUpdateTypeRef root child,+      "            { " <> T.intercalate ",\n              " setFields,+      "            })",+      "      pure $ case result of",+      "        Left err -> Left err",+      "        Right _ -> Right ()"+    ]+  where+    fk = fkField child rel+    setFields =+      [ if fieldName f == fieldName fk+          then fieldName f <> " = " <> connectFkValue fk+          else fieldName f <> " = " <> leaveFkValue f+        | f <- updateFields child+      ]++emitDisconnectFn :: Model -> NestedRel -> Text+emitDisconnectFn root (rel, child) =+  T.unlines+    [ disconnectFnName rel <> " :: " <> pkHsType root <> " -> [" <> childUniqueTypeRef root child <> "] -> Db (Either ORMError ())",+      disconnectFnName rel <> " _ [] = pure (Right ())",+      disconnectFnName rel <> " parentId keys = sequenceNested (map disconnectOne keys)",+      "  where",+      "    disconnectOne key = do",+      "      result <-",+      "        Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child,+      "          (" <> childUniqueWhereRef root child <> " key `and_` eq " <> fkBinder <> " parentId)",+      "          (" <> childUpdateTypeRef root child,+      "            { " <> T.intercalate ",\n              " setFields,+      "            })",+      "      pure $ case result of",+      "        Left err -> Left err",+      "        Right _ -> Right ()"+    ]+  where+    fk = fkField child rel+    fkBinder = fieldBinder child fk+    setFields =+      [ if fieldName f == fieldName fk+          then fieldName f <> " = Null"+          else fieldName f <> " = " <> leaveFkValue f+        | f <- updateFields child+      ]++nestedChildSchemaImports :: Text -> Schema -> Model -> [Text]+nestedChildSchemaImports moduleName schema root =+  [ childSchemaImport moduleName nested+    | nested@(_, child) <- uniqueByChild (nestedWriteRelations schema root),+      modelName child /= modelName root+  ]++childSchemaImport :: Text -> NestedRel -> Text+childSchemaImport moduleName (rel, child) =+  "import "+    <> schemaModuleFor moduleName child+    <> " ("+    <> T.intercalate ", " names+    <> ")"+  where+    names =+      [ rowTypeName child <> " (..)",+        tableTypeName child,+        fieldBinder child (primaryKeyField child),+        fieldBinder child (fkField child rel)+      ]+        ++ [ createTypeName child <> " (..)",+             updateTypeName child <> " (..)"+           ]++nestedChildClientImports :: Text -> Schema -> Model -> [Text]+nestedChildClientImports moduleName schema root =+  [ childClientImport moduleName child+    | (_, child) <- uniqueByChild (nestedWriteRelations schema root),+      modelName child /= modelName root+  ]++childClientImport :: Text -> Model -> Text+childClientImport moduleName child =+  "import qualified "+    <> childClientModule moduleName child+    <> " as "+    <> modelName child+    <> " ("+    <> uniqueTypeName child+    <> " (..), "+    <> uniqueWhereName child+    <> ")"++childClientModule :: Text -> Model -> Text+childClientModule clientModule child =+  case T.breakOnEnd "." clientModule of+    (prefix, _) -> prefix <> modelName child++nestedChildEnumImports :: Text -> Schema -> Model -> [Text]+nestedChildEnumImports moduleName schema root =+  nub+    [ "import " <> clientSchemaPrefix moduleName <> enumName e <> " (" <> enumName e <> " (..))"+      | (_, child) <- uniqueByChild (nestedWriteRelations schema root),+        f <- modelFields child,+        TyEnum wanted <- [fieldType f],+        e <- schemaEnums schema,+        enumName e == wanted,+        isNothing (enumImport e)+    ]
+ src/Poppy/Codegen/Emit/Schema.hs view
@@ -0,0 +1,500 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Emit.Schema+  ( emitModelModule,+    emitEnumModule,+    enumImportLine,+    schemaEnumPrefix,+  )+where++import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.EmitCommon+  ( CreateKind (..),+    createHsType,+    createKind,+    createTypeName,+    fieldBinder,+    hsType,+    parsePickedName,+    pickedTypeName,+    pkHsType,+    primaryKeyField,+    rowTypeName,+    selectColumnsFnName,+    selectDefaultName,+    selectTypeName,+    tableTypeName,+    toPickedName,+    updateFields,+    updateHsType,+    updateTypeName,+  )+import Poppy.Codegen.IR+import Poppy.Codegen.Lookup (lookupField, lookupUniques)+import Poppy.Codegen.TextUtil (lowerFirst)++emitModelModule :: Text -> Schema -> Model -> Text+emitModelModule moduleName schema model =+  T.unlines $+    concat+      [ pragmas,+        [ "module " <> moduleName,+          emitExports model,+          "where",+          "",+          imports moduleName schema model,+          "",+          "data " <> tableName_ <> " = " <> tableName_,+          "",+          "type instance PrimaryKeyType " <> tableName_ <> " = " <> pkHsType model,+          "",+          "type instance ModelTable \"" <> modelName model <> "\" = " <> tableName_,+          "",+          "instance Entity " <> tableName_ <> " where",+          "  tableName = \"" <> modelTable model <> "\"",+          "  primaryKey = " <> fieldBinder model pkField,+          "  tableColumns = [" <> T.intercalate ", " (map colLit (modelFields model)) <> "]"+        ]+          ++ uniqueKeysLines schema model+          ++ [ "",+               emitInsertable model,+               "",+               emitUpdatable model,+               "",+               emitRow model,+               "",+               emitCreate model,+               "",+               emitUpdate model,+               "",+               emitFromRow model,+               "",+               emitSelectTypes model,+               ""+             ],+        concatMap (emitFieldDecl model) (modelFields model)+      ]+  where+    tableName_ = tableTypeName model+    pkField = primaryKeyField model++emitExports :: Model -> Text+emitExports model =+  "  ( "+    <> T.intercalate ",\n    " items+    <> "\n  )"+  where+    items =+      [ tableTypeName model <> " (..)",+        rowTypeName model <> " (..)",+        selectTypeName model <> " (..)",+        pickedTypeName model <> " (..)",+        selectDefaultName model,+        selectColumnsFnName model,+        parsePickedName model,+        toPickedName model,+        createTypeName model <> " (..)",+        updateTypeName model <> " (..)"+      ]+        ++ map (fieldBinder model) (modelFields model)++pragmas :: [Text]+pragmas =+  [ "{-# LANGUAGE AllowAmbiguousTypes #-}",+    "{-# LANGUAGE DataKinds #-}",+    "{-# LANGUAGE DuplicateRecordFields #-}",+    "{-# LANGUAGE NoFieldSelectors #-}",+    "{-# LANGUAGE OverloadedRecordDot #-}",+    "{-# LANGUAGE TypeApplications #-}",+    ""+  ]++imports :: Text -> Schema -> Model -> Text+imports moduleName schema model =+  T.intercalate "\n" $+    filter+      (not . T.null)+      [ "import Data.Text (Text)",+        if needsTime model then "import Data.Time (UTCTime)" else "",+        if needsUuid model then "import Data.UUID (UUID)" else "",+        if needsScientific model then "import Data.Scientific (Scientific)" else "",+        if needsJsonb model then "import Data.Aeson (Value)" else "",+        generatedImport model+      ]+      ++ enumImports moduleName schema model++enumImports :: Text -> Schema -> Model -> [Text]+enumImports moduleName schema model =+  [ enumImportLine (schemaEnumPrefix moduleName) e+    | e <- schemaEnums schema,+      enumName e `elem` usedEnumNames+  ]+  where+    usedEnumNames =+      [ name+        | f <- modelFields model,+          TyEnum name <- [fieldType f]+      ]++schemaEnumPrefix :: Text -> Text+schemaEnumPrefix moduleName =+  case T.breakOnEnd "." moduleName of+    (prefix, _) | not (T.null prefix) -> prefix+    _ -> ""++enumImportLine :: Text -> EnumSpec -> Text+enumImportLine prefix e =+  "import " <> enumImportModule prefix e <> " (" <> enumName e <> ")"++enumImportModule :: Text -> EnumSpec -> Text+enumImportModule prefix e =+  case enumImport e of+    Just imp -> imp+    Nothing -> prefix <> enumName e++enumToStringName :: EnumSpec -> Text+enumToStringName e = lowerFirst (enumName e) <> "ToString"++emitEnumModule :: Text -> EnumSpec -> Text+emitEnumModule moduleName e =+  T.unlines+    [ "{-# LANGUAGE OverloadedStrings #-}",+      "",+      "module " <> moduleName,+      "  ( " <> enumName e <> " (..),",+      "    " <> enumToStringName e,+      "  )",+      "where",+      "",+      "import Data.Maybe (isNothing)",+      "import Data.Text (Text)",+      "import Poppy.Internal.Generated",+      "  ( FromField (..),",+      "    ResultError (ConversionFailed, UnexpectedNull),",+      "    returnError,",+      "    ToField (..),",+      "    toField,",+      "  )",+      "",+      emitEnumData e,+      "",+      emitEnumFromField e,+      "",+      emitEnumToField e,+      "",+      emitEnumToString e+    ]++emitEnumData :: EnumSpec -> Text+emitEnumData e =+  T.unlines+    [ "data " <> enumName e <> " = " <> T.intercalate " | " (map variantName (enumVariants e)),+      "  deriving (Show, Eq)"+    ]++emitEnumFromField :: EnumSpec -> Text+emitEnumFromField e =+  T.unlines $+    [ "instance FromField " <> enumName e <> " where",+      "  fromField f bs",+      "    | isNothing bs = returnError UnexpectedNull f \"\""+    ]+      ++ [ "    | bs == Just \"" <> variantDbStr v <> "\" = pure " <> variantName v+           | v <- enumVariants e+         ]+      ++ ["    | otherwise = returnError ConversionFailed f \"\""]++emitEnumToField :: EnumSpec -> Text+emitEnumToField e =+  T.unlines+    [ "instance ToField " <> enumName e <> " where",+      "  toField = toField . " <> enumToStringName e+    ]++emitEnumToString :: EnumSpec -> Text+emitEnumToString e =+  T.unlines $+    (enumToStringName e <> " :: " <> enumName e <> " -> Text")+      : [ enumToStringName e <> " " <> variantName v <> " = \"" <> variantDbStr v <> "\""+          | v <- enumVariants e+        ]++variantDbStr :: EnumVariant -> Text+variantDbStr v = fromMaybe (lowerFirst (variantName v)) (variantDbValue v)++generatedImport :: Model -> Text+generatedImport model =+  let needsNullable = any fieldNullable (modelFields model)+      needsMaybe = any ((== CreateMaybe) . createKind) (modelFields model)+      needsUpdateNullable = any fieldNullable (updateFields model)+      needsUpdateMaybe = (not . all fieldNullable) (updateFields model)+      parts =+        [ "FromRow (..)",+          "RowParser",+          "field",+          "Entity (..)",+          "Field (..)",+          "PrimaryKeyType",+          "ModelTable",+          "Picked (..)",+          "picked",+          "Insertable (..)",+          "emptyInsert"+        ]+          ++ ["NullableValue (..)" | needsNullable]+          ++ ["set" | hasRequiredCreateField model]+          ++ ["setMaybe" | needsMaybe]+          ++ ["setNullable" | needsNullable]+          ++ ["Updatable (..)", "emptyUpdate"]+          ++ ["setFieldMaybe" | needsUpdateMaybe]+          ++ ["setFieldNullable" | needsUpdateNullable]+   in "import Poppy.Internal.Generated\n  ( "+        <> T.intercalate ",\n    " parts+        <> "\n  )"++needsTime :: Model -> Bool+needsTime = any ((== TyTimestamptz) . fieldType) . modelFields++needsUuid :: Model -> Bool+needsUuid = any (isUuidType . fieldType) . modelFields+  where+    isUuidType TyUuid = True+    isUuidType _ = False++needsScientific :: Model -> Bool+needsScientific = any ((== TyNumeric) . fieldType) . modelFields++needsJsonb :: Model -> Bool+needsJsonb = any ((== TyJsonb) . fieldType) . modelFields++hasRequiredCreateField :: Model -> Bool+hasRequiredCreateField =+  any (\f -> createKind f == CreateRequired) . modelFields++rowHsType :: FieldSpec -> Text+rowHsType f+  | fieldNullable f = "Maybe " <> hsType (fieldType f)+  | otherwise = hsType (fieldType f)++emitRow :: Model -> Text+emitRow model =+  T.unlines+    [ "data " <> rowTypeName model <> " = " <> rowTypeName model,+      "  { " <> T.intercalate ",\n    " (map rowField (modelFields model)),+      "  }",+      "  deriving (Show, Eq)"+    ]+  where+    rowField f = fieldName f <> " :: " <> rowHsType f++emitCreate :: Model -> Text+emitCreate model =+  T.unlines+    [ "data " <> createTypeName model <> " = " <> createTypeName model,+      "  { " <> T.intercalate ",\n    " (map createField (modelFields model)),+      "  }",+      "  deriving (Show, Eq)"+    ]+  where+    createField f = fieldName f <> " :: " <> createHsType f++emitUpdate :: Model -> Text+emitUpdate model =+  T.unlines+    [ "data " <> updateTypeName model <> " = " <> updateTypeName model,+      "  { " <> T.intercalate ",\n    " (map updateField (updateFields model)),+      "  }",+      "  deriving (Show, Eq)"+    ]+  where+    updateField f = fieldName f <> " :: " <> updateHsType f++emitFromRow :: Model -> Text+emitFromRow model =+  let n = length (modelFields model)+      fields = T.intercalate " <*> " (replicate n "field")+   in T.unlines+        [ "instance FromRow " <> rowTypeName model <> " where",+          "  fromRow = " <> rowTypeName model <> " <$> " <> fields+        ]++colLit :: FieldSpec -> Text+colLit f = "\"" <> fieldColumn f <> "\""++uniqueKeysLines :: Schema -> Model -> [Text]+uniqueKeysLines schema model =+  case lookupUniques schema (modelName model) of+    [] -> []+    uniques ->+      [ "  uniqueKeys = ["+          <> T.intercalate ", " (map emitKey (pkCols : map uniqueCols uniques))+          <> "]"+      ]+  where+    pkCols = [fieldColumn (primaryKeyField model)]+    uniqueCols constraint = map (fieldColumn . lookupField model) (uniqueFields constraint)+    emitKey cols = "[" <> T.intercalate ", " (map (\c -> "\"" <> c <> "\"") cols) <> "]"++pickedFieldHsType :: FieldSpec -> Text+pickedFieldHsType f+  | fieldIsPrimaryKey f = rowHsType f+  | fieldNullable f = "Picked (" <> rowHsType f <> ")"+  | otherwise = "Picked " <> rowHsType f++emitSelectTypes :: Model -> Text+emitSelectTypes model =+  T.intercalate "\n" (map T.strip sections) <> "\n"+  where+    sections =+      [ emitSelectRecord model,+        emitPickedRecord model,+        emitSelectDefault model,+        emitSelectColumnsFn model,+        emitParsePicked model,+        emitToPicked model+      ]++emitSelectRecord :: Model -> Text+emitSelectRecord model =+  T.unlines+    [ "data " <> selectTypeName model <> " = " <> selectTypeName model,+      "  { " <> T.intercalate ",\n    " (map selectField (modelFields model)),+      "  }",+      "  deriving (Show, Eq)"+    ]+  where+    selectField f = fieldName f <> " :: Bool"++emitPickedRecord :: Model -> Text+emitPickedRecord model =+  T.unlines+    [ "data " <> pickedTypeName model <> " = " <> pickedTypeName model,+      "  { " <> T.intercalate ",\n    " (map pickedField (modelFields model)),+      "  }",+      "  deriving (Show, Eq)"+    ]+  where+    pickedField f = fieldName f <> " :: " <> pickedFieldHsType f++emitSelectDefault :: Model -> Text+emitSelectDefault model =+  T.unlines+    [ selectDefaultName model <> " :: " <> selectTypeName model,+      selectDefaultName model <> " =",+      "  " <> selectTypeName model,+      "    { " <> T.intercalate ",\n      " (map falseField (modelFields model)),+      "    }"+    ]+  where+    falseField f = fieldName f <> " = False"++emitSelectColumnsFn :: Model -> Text+emitSelectColumnsFn model =+  T.unlines+    [ selectColumnsFnName model <> " :: " <> selectTypeName model <> " -> [Text]",+      selectColumnsFnName model <> " select_ =",+      "  fieldColumn " <> fieldBinder model pkSpec,+      "    : concat",+      "      [ " <> T.intercalate "\n      , " (map colGuard others),+      "      ]"+    ]+  where+    pkSpec = primaryKeyField model+    others = filter (not . fieldIsPrimaryKey) (modelFields model)+    colGuard f =+      "[fieldColumn " <> fieldBinder model f <> " | select_." <> fieldName f <> "]"++emitParsePicked :: Model -> Text+emitParsePicked model =+  T.unlines $+    [ parsePickedName model <> " :: " <> selectTypeName model <> " -> RowParser " <> pickedTypeName model,+      parsePickedName model <> " select_ = do",+      "  " <> pkName <> "Val <- field"+    ]+      ++ map parseLine others+      ++ [ "  pure "+             <> pickedTypeName model+             <> " { "+             <> T.intercalate ", " assignFields+             <> " }"+         ]+  where+    pkSpec = primaryKeyField model+    pkName = fieldName pkSpec+    others = filter (not . fieldIsPrimaryKey) (modelFields model)+    parseLine f =+      "  " <> fieldName f <> "Val <- if select_." <> fieldName f <> " then Picked <$> field else pure Skipped"+    assignFields =+      (pkName <> " = " <> pkName <> "Val")+        : [fieldName f <> " = " <> fieldName f <> "Val" | f <- others]++emitToPicked :: Model -> Text+emitToPicked model =+  T.unlines+    [ toPickedName model <> " :: " <> selectTypeName model <> " -> " <> rowTypeName model <> " -> " <> pickedTypeName model,+      toPickedName model <> " select_ row =",+      "  " <> pickedTypeName model,+      "    { " <> T.intercalate ",\n      " assignFields,+      "    }"+    ]+  where+    assignFields = map assign (modelFields model)+    assign f+      | fieldIsPrimaryKey f = fieldName f <> " = row." <> fieldName f+      | otherwise = fieldName f <> " = picked select_." <> fieldName f <> " row." <> fieldName f++emitFieldDecl :: Model -> FieldSpec -> [Text]+emitFieldDecl model f =+  [ binder <> " :: Field " <> tableTypeName model <> " " <> hsType (fieldType f),+    binder <> " = Field \"" <> fieldName f <> "\" \"" <> fieldColumn f <> "\"",+    ""+  ]+  where+    binder = fieldBinder model f++emitInsertable :: Model -> Text+emitInsertable model =+  T.unlines+    [ "instance Insertable " <> tableTypeName model <> " where",+      "  type CreateInput " <> tableTypeName model <> " = " <> createTypeName model,+      "  toInsertBuilder input =",+      "    " <> body+    ]+  where+    fields = modelFields model+    body = foldr wrap ("emptyInsert @" <> tableTypeName model) fields+    wrap f inner = case createKind f of+      CreateNullable ->+        "setNullable " <> fieldBinder model f <> " input." <> fieldName f <> " $\n      " <> inner+      CreateMaybe ->+        "setMaybe " <> fieldBinder model f <> " input." <> fieldName f <> " $\n      " <> inner+      CreateRequired ->+        "set " <> fieldBinder model f <> " input." <> fieldName f <> " $\n      " <> inner++emitUpdatable :: Model -> Text+emitUpdatable model =+  T.unlines+    [ "instance Updatable " <> tableTypeName model <> " where",+      "  type UpdateInput " <> tableTypeName model <> " = " <> updateTypeName model,+      updatedAtLine,+      "  toUpdateBuilder input =",+      "    " <> body+    ]+  where+    fields = updateFields model+    body = foldr wrap ("emptyUpdate @" <> tableTypeName model) fields+    wrap f inner+      | fieldNullable f =+          "setFieldNullable " <> fieldBinder model f <> " input." <> fieldName f <> " $\n      " <> inner+      | otherwise =+          "setFieldMaybe " <> fieldBinder model f <> " input." <> fieldName f <> " $\n      " <> inner+    updatedAtLine =+      case mapMaybe updatedAtBinder (modelFields model) of+        (b : _) -> "  updatedAtField = Just " <> b+        [] -> "  updatedAtField = Nothing"+    updatedAtBinder f+      | fieldUpdatedAt f = Just (fieldBinder model f)+      | otherwise = Nothing
+ src/Poppy/Codegen/EmitCommon.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.EmitCommon+  ( fieldBinder,+    hsType,+    primaryKeyField,+    includeFieldName,+    createTypeName,+    updateTypeName,+    tableTypeName,+    rowTypeName,+    selectTypeName,+    pickedTypeName,+    selectDefaultName,+    selectColumnsFnName,+    parsePickedName,+    toPickedName,+    uniqueTypeName,+    uniqueWhereName,+    uniqueKeyTypeName,+    CreateKind (..),+    createKind,+    createHsType,+    updateHsType,+    updateFields,+    pkHsType,+    clientSchemaPrefix,+    schemaModuleFor,+  )+where++import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.IR+import Poppy.Codegen.TextUtil (lowerFirst, upperFirst)++fieldBinder :: Model -> FieldSpec -> Text+fieldBinder model f =+  lowerFirst (modelName model) <> upperFirst (fieldName f)++hsType :: FieldType -> Text+hsType TyText = "Text"+hsType TyUuid = "UUID"+hsType TyInt = "Int"+hsType TyNumeric = "Scientific"+hsType TyJsonb = "Value"+hsType TyTimestamptz = "UTCTime"+hsType TyBool = "Bool"+hsType (TyEnum name) = name++primaryKeyField :: Model -> FieldSpec+primaryKeyField model =+  case filter fieldIsPrimaryKey (modelFields model) of+    [f] -> f+    _ ->+      error $+        "Poppy.Codegen.EmitCommon: model "+          <> T.unpack (modelName model)+          <> " must have exactly one primary key"++includeFieldName :: Model -> RelationSpec -> Text+includeFieldName _parent = relName++createTypeName :: Model -> Text+createTypeName model = modelName model <> "Create"++updateTypeName :: Model -> Text+updateTypeName model = modelName model <> "Update"++tableTypeName :: Model -> Text+tableTypeName model = modelName model <> "Table"++rowTypeName :: Model -> Text+rowTypeName model = modelName model <> "Row"++selectTypeName :: Model -> Text+selectTypeName model = modelName model <> "Select"++pickedTypeName :: Model -> Text+pickedTypeName model = modelName model <> "Picked"++selectDefaultName :: Model -> Text+selectDefaultName model = lowerFirst (modelName model) <> "Select"++selectColumnsFnName :: Model -> Text+selectColumnsFnName model = lowerFirst (modelName model) <> "SelectColumns"++parsePickedName :: Model -> Text+parsePickedName model = "parse" <> modelName model <> "Picked"++toPickedName :: Model -> Text+toPickedName model = "to" <> modelName model <> "Picked"++uniqueTypeName :: Model -> Text+uniqueTypeName model = modelName model <> "Unique"++uniqueWhereName :: Model -> Text+uniqueWhereName model = lowerFirst (modelName model) <> "UniqueWhere"++uniqueKeyTypeName :: Model -> Text+uniqueKeyTypeName model = modelName model <> "UniqueKey"++data CreateKind = CreateMaybe | CreateNullable | CreateRequired+  deriving (Eq)++createKind :: FieldSpec -> CreateKind+createKind f+  | fieldIsPrimaryKey f && isJust (fieldDefault f) = CreateMaybe+  | fieldIsPrimaryKey f = CreateRequired+  | isJust (fieldDefault f) = CreateMaybe+  | fieldNullable f = CreateNullable+  | otherwise = CreateRequired++createHsType :: FieldSpec -> Text+createHsType f = case createKind f of+  CreateMaybe -> "Maybe " <> hsType (fieldType f)+  CreateNullable -> "NullableValue " <> hsType (fieldType f)+  CreateRequired -> hsType (fieldType f)++updateFields :: Model -> [FieldSpec]+updateFields = filter (not . fieldIsPrimaryKey) . modelFields++updateHsType :: FieldSpec -> Text+updateHsType f+  | fieldNullable f = "NullableValue " <> hsType (fieldType f)+  | otherwise = "Maybe " <> hsType (fieldType f)++pkHsType :: Model -> Text+pkHsType model = hsType (fieldType (primaryKeyField model))++-- | Schema types live next to the Client unless the Client is nested under Schema.+--+-- @Foo.Client.Bar@ → @Foo.Schema.@ (sibling Client/Schema packages)+-- @Schema.Client.Bar@ → @Schema.@ (Client nested under Schema)+clientSchemaPrefix :: Text -> Text+clientSchemaPrefix clientModule =+  case T.breakOnEnd ".Client." clientModule of+    (before, after)+      | not (T.null after) && ".Client." `T.isSuffixOf` before ->+          let parent = T.take (T.length before - T.length ".Client.") before+           in if parent == "Schema"+                then "Schema."+                else parent <> ".Schema."+    _ -> "Schema."++schemaModuleFor :: Text -> Model -> Text+schemaModuleFor clientModule model =+  clientSchemaPrefix clientModule <> modelName model
+ src/Poppy/Codegen/IR.hs view
@@ -0,0 +1,227 @@+-- | Schema value types. Application code builds Schemas with "Poppy.Codegen.Schema", not this module.+module Poppy.Codegen.IR+  ( Schema (..),+    Model (..),+    EnumSpec (..),+    EnumVariant (..),+    FieldSpec (..),+    FieldType (..),+    FieldDefault (..),+    RelationSpec (..),+    RelationKind (..),+    JoinKind (..),+    UniqueConstraint (..),+    field,+    uuid,+    text,+    int,+    numeric,+    jsonb,+    timestamptz,+    bool,+    enumField,+    pk,+    nullable,+    updatedAt,+    withDefault,+    column,+    enum_,+    enumImportFrom,+    variant,+    variantMap,+    hasMany,+    belongsTo,+    unique_,+  )+where++import Data.Text (Text)++-- | Enums, models, and uniques.+data Schema = Schema+  { schemaEnums :: [EnumSpec],+    schemaModels :: [Model],+    schemaUniques :: [UniqueConstraint]+  }+  deriving (Show, Eq)++-- | Unique constraint: model name plus field names (not columns).+data UniqueConstraint = UniqueConstraint+  { uniqueModel :: Text,+    uniqueFields :: [Text]+  }+  deriving (Show, Eq)++-- | Postgres enum in the Schema.+data EnumSpec = EnumSpec+  { enumName :: Text,+    enumVariants :: [EnumVariant],+    enumImport :: Maybe Text+  }+  deriving (Show, Eq)++-- | Haskell constructor and optional distinct Postgres label.+data EnumVariant = EnumVariant+  { variantName :: Text,+    variantDbValue :: Maybe Text+  }+  deriving (Show, Eq)++-- | One table: fields and relations.+data Model = Model+  { modelName :: Text,+    modelTable :: Text,+    modelFields :: [FieldSpec],+    modelRelations :: [RelationSpec]+  }+  deriving (Show, Eq)++-- | Column types Codegen emits and drift-checks.+data FieldType+  = TyText+  | TyUuid+  | TyInt+  | TyNumeric+  | TyJsonb+  | TyTimestamptz+  | TyBool+  | TyEnum Text+  deriving (Show, Eq)++-- | Application-side default; the SQL column must have a matching @DEFAULT@.+data FieldDefault+  = DefaultUuidV4+  | DefaultNow+  deriving (Show, Eq)++-- | One column on a model.+data FieldSpec = FieldSpec+  { fieldName :: Text,+    fieldColumn :: Text,+    fieldType :: FieldType,+    fieldNullable :: Bool,+    fieldIsPrimaryKey :: Bool,+    fieldDefault :: Maybe FieldDefault,+    fieldUpdatedAt :: Bool+  }+  deriving (Show, Eq)++-- | @RelHasMany@ or @RelBelongsTo@.+data RelationKind = RelHasMany | RelBelongsTo+  deriving (Show, Eq)++-- | @LEFT@ / @INNER@ / @RIGHT@ for ad-hoc join emission.+data JoinKind = JoinLeft | JoinInner | JoinRight+  deriving (Show, Eq)++-- | @hasMany@ or @belongsTo@ edge on a model.+data RelationSpec = RelationSpec+  { relName :: Text,+    relKind :: RelationKind,+    relFromModel :: Text,+    relToModel :: Text,+    relLocalField :: Text,+    relForeignField :: Text,+    relJoin :: JoinKind+  }+  deriving (Show, Eq)++field :: Text -> FieldType -> FieldSpec+field name ty =+  FieldSpec+    { fieldName = name,+      fieldColumn = name,+      fieldType = ty,+      fieldNullable = False,+      fieldIsPrimaryKey = False,+      fieldDefault = Nothing,+      fieldUpdatedAt = False+    }++uuid :: Text -> FieldSpec+uuid name = field name TyUuid++text :: Text -> FieldSpec+text name = field name TyText++int :: Text -> FieldSpec+int name = field name TyInt++numeric :: Text -> FieldSpec+numeric name = field name TyNumeric++jsonb :: Text -> FieldSpec+jsonb name = field name TyJsonb++timestamptz :: Text -> FieldSpec+timestamptz name = field name TyTimestamptz++bool :: Text -> FieldSpec+bool name = field name TyBool++enumField :: Text -> Text -> FieldSpec+enumField name enumName = field name (TyEnum enumName)++-- | Exactly one primary key per model.+pk :: FieldSpec -> FieldSpec+pk f = f {fieldIsPrimaryKey = True}++-- | @Maybe@ on the row; create/update use 'Poppy.NullableValue'.+nullable :: FieldSpec -> FieldSpec+nullable f = f {fieldNullable = True}++-- | Client writes set this column to now.+updatedAt :: FieldSpec -> FieldSpec+updatedAt f = f {fieldUpdatedAt = True}++withDefault :: FieldDefault -> FieldSpec -> FieldSpec+withDefault d f = f {fieldDefault = Just d}++column :: Text -> FieldSpec -> FieldSpec+column col f = f {fieldColumn = col}++-- | Postgres enum. Labels default to the Haskell constructor names.+enum_ :: Text -> [EnumVariant] -> EnumSpec+enum_ name variants =+  EnumSpec {enumName = name, enumVariants = variants, enumImport = Nothing}++-- | Skip generating the sum type; import this module instead.+enumImportFrom :: Text -> EnumSpec -> EnumSpec+enumImportFrom moduleName e = e {enumImport = Just moduleName}++-- | Enum constructor; Postgres label is the same spelling.+variant :: Text -> EnumVariant+variant name = EnumVariant {variantName = name, variantDbValue = Nothing}++-- | Enum constructor with a different Postgres label.+variantMap :: Text -> Text -> EnumVariant+variantMap name dbValue =+  EnumVariant {variantName = name, variantDbValue = Just dbValue}++hasMany :: Text -> Text -> Text -> Text -> Text -> RelationSpec+hasMany name fromModel toModel localFld foreignFld =+  RelationSpec+    { relName = name,+      relKind = RelHasMany,+      relFromModel = fromModel,+      relToModel = toModel,+      relLocalField = localFld,+      relForeignField = foreignFld,+      relJoin = JoinLeft+    }++belongsTo :: Text -> Text -> Text -> Text -> Text -> RelationSpec+belongsTo name fromModel toModel foreignFld referencedFld =+  RelationSpec+    { relName = name,+      relKind = RelBelongsTo,+      relFromModel = fromModel,+      relToModel = toModel,+      relLocalField = referencedFld,+      relForeignField = foreignFld,+      relJoin = JoinLeft+    }++-- | Unique constraint (field names, not columns). @findUnique@ and @upsert@ conflict use these.+unique_ :: Text -> [Text] -> UniqueConstraint+unique_ model fields = UniqueConstraint {uniqueModel = model, uniqueFields = fields}
+ src/Poppy/Codegen/Introspect.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Introspect+  ( introspectCatalog,+    canonicalizeColumnType,+  )+where++import Data.Int (Int32)+import Data.List (foldl', sortOn)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Database.PostgreSQL.Simple (Connection, query_)+import Database.PostgreSQL.Simple.Types (Query)+import Poppy.Codegen.Drift (DbCatalog (..), DbColumn (..), DbForeignKey (..), DbTable (..), emptyCatalog)++type ColumnRow = (Text, Text, Text, Text, Text, Maybe Text)++type PkRow = (Text, Text, Int32)++type UniqueRow = (Text, Text, Text, Int32)++type EnumRow = (Text, Text)++type FkRow = (Text, Text, Text, Text)++introspectCatalog :: Connection -> IO DbCatalog+introspectCatalog conn = do+  columns <- query_ conn columnSql+  pks <- query_ conn pkSql+  uniques <- query_ conn uniqueSql+  enums <- query_ conn enumSql+  fks <- query_ conn fkSql+  pure $+    emptyCatalog+      { dbTables = buildTables columns pks uniques,+        dbEnums = buildEnums enums,+        dbForeignKeys = buildForeignKeys fks+      }++canonicalizeColumnType :: Text -> Text -> Text+canonicalizeColumnType dataType udtName =+  case dataType of+    "text" -> "text"+    "uuid" -> "uuid"+    "integer" -> "int"+    "numeric" -> "numeric"+    "jsonb" -> "jsonb"+    "timestamp with time zone" -> "timestamptz"+    "boolean" -> "boolean"+    "USER-DEFINED" -> "enum:" <> udtName+    _ -> udtName++buildTables :: [ColumnRow] -> [PkRow] -> [UniqueRow] -> Map Text DbTable+buildTables columns pks uniques =+  Map.mapWithKey+    ( \name table ->+        table+          { dbPrimaryKey = Map.findWithDefault [] name pkMap,+            dbUniques = Map.findWithDefault [] name uniqueMap+          }+    )+    columnTables+  where+    columnTables = foldl' addColumn Map.empty columns+    pkMap = Map.fromListWith (flip (++)) [(table, [col]) | (table, col, _) <- sortOn pkOrd pks]+    uniqueMap = uniqueSets uniques++addColumn :: Map Text DbTable -> ColumnRow -> Map Text DbTable+addColumn acc (table, col, nullable, dataType, udtName, columnDefault) =+  Map.alter upsert table acc+  where+    column =+      DbColumn+        { dbColName = col,+          dbColType = canonicalizeColumnType dataType udtName,+          dbColNullable = nullable == "YES",+          dbColDefault = columnDefault+        }+    upsert Nothing =+      Just+        DbTable+          { dbTableName = table,+            dbColumns = Map.singleton col column,+            dbPrimaryKey = [],+            dbUniques = []+          }+    upsert (Just existing) =+      Just existing {dbColumns = Map.insert col column (dbColumns existing)}++pkOrd :: PkRow -> (Text, Int32)+pkOrd (table, _, pos) = (table, pos)++uniqueSets :: [UniqueRow] -> Map Text [Set Text]+uniqueSets rows =+  Map.fromListWith+    (++)+    [ (table, [Set.fromList (map (\(_, _, col, _) -> col) grouped)])+      | grouped@((table, _, _, _) : _) <- groupByConstraint (sortOn uniqueOrd rows)+    ]++uniqueOrd :: UniqueRow -> (Text, Text, Int32)+uniqueOrd (table, constraint, _, pos) = (table, constraint, pos)++groupByConstraint :: [UniqueRow] -> [[UniqueRow]]+groupByConstraint [] = []+groupByConstraint (row : rest) =+  let (same, others) = span (sameConstraint row) rest+   in (row : same) : groupByConstraint others++sameConstraint :: UniqueRow -> UniqueRow -> Bool+sameConstraint (tableA, nameA, _, _) (tableB, nameB, _, _) =+  tableA == tableB && nameA == nameB++buildEnums :: [EnumRow] -> Map Text [Text]+buildEnums rows =+  Map.fromListWith (flip (++)) [(name, [label]) | (name, label) <- rows]++buildForeignKeys :: [FkRow] -> [DbForeignKey]+buildForeignKeys =+  map+    ( \(fromTable, fromCol, toTable, toCol) ->+        DbForeignKey+          { dbFkFromTable = fromTable,+            dbFkFromColumn = fromCol,+            dbFkToTable = toTable,+            dbFkToColumn = toCol+          }+    )++columnSql :: Query+columnSql =+  "SELECT table_name, column_name, is_nullable, data_type, udt_name, column_default\+  \ FROM information_schema.columns\+  \ WHERE table_schema = 'public'"++pkSql :: Query+pkSql =+  "SELECT kcu.table_name, kcu.column_name, kcu.ordinal_position\+  \ FROM information_schema.table_constraints tc\+  \ JOIN information_schema.key_column_usage kcu\+  \   ON tc.constraint_name = kcu.constraint_name\+  \  AND tc.table_schema = kcu.table_schema\+  \ WHERE tc.table_schema = 'public'\+  \   AND tc.constraint_type = 'PRIMARY KEY'\+  \ ORDER BY kcu.table_name, kcu.ordinal_position"++uniqueSql :: Query+uniqueSql =+  "SELECT kcu.table_name, tc.constraint_name, kcu.column_name, kcu.ordinal_position\+  \ FROM information_schema.table_constraints tc\+  \ JOIN information_schema.key_column_usage kcu\+  \   ON tc.constraint_name = kcu.constraint_name\+  \  AND tc.table_schema = kcu.table_schema\+  \ WHERE tc.table_schema = 'public'\+  \   AND tc.constraint_type = 'UNIQUE'\+  \ ORDER BY kcu.table_name, tc.constraint_name, kcu.ordinal_position"++enumSql :: Query+enumSql =+  "SELECT t.typname, e.enumlabel\+  \ FROM pg_type t\+  \ JOIN pg_enum e ON t.oid = e.enumtypid\+  \ ORDER BY t.typname, e.enumsortorder"++fkSql :: Query+fkSql =+  "SELECT kcu.table_name, kcu.column_name, ccu.table_name, ccu.column_name\+  \ FROM information_schema.table_constraints tc\+  \ JOIN information_schema.key_column_usage kcu\+  \   ON tc.constraint_name = kcu.constraint_name\+  \  AND tc.table_schema = kcu.table_schema\+  \ JOIN information_schema.constraint_column_usage ccu\+  \   ON ccu.constraint_name = tc.constraint_name\+  \  AND ccu.constraint_schema = tc.table_schema\+  \ WHERE tc.table_schema = 'public'\+  \   AND tc.constraint_type = 'FOREIGN KEY'"
+ src/Poppy/Codegen/Lookup.hs view
@@ -0,0 +1,47 @@+module Poppy.Codegen.Lookup+  ( lookupModel,+    lookupField,+    lookupRelation,+    lookupUniques,+  )+where++import Data.List (find)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.IR++lookupModel :: Schema -> Text -> Model+lookupModel schema name =+  case find ((== name) . modelName) (schemaModels schema) of+    Just foundModel -> foundModel+    Nothing ->+      error $+        "Poppy.Codegen.Lookup: unknown model "+          <> T.unpack name++lookupField :: Model -> Text -> FieldSpec+lookupField model name =+  case find ((== name) . fieldName) (modelFields model) of+    Just spec -> spec+    Nothing ->+      error $+        "Poppy.Codegen.Lookup: unknown field "+          <> T.unpack name+          <> " on "+          <> T.unpack (modelName model)++lookupRelation :: Model -> Text -> RelationSpec+lookupRelation model name =+  case find ((== name) . relName) (modelRelations model) of+    Just relation -> relation+    Nothing ->+      error $+        "Poppy.Codegen.Lookup: unknown relation "+          <> T.unpack name+          <> " on "+          <> T.unpack (modelName model)++lookupUniques :: Schema -> Text -> [UniqueConstraint]+lookupUniques schema name =+  filter ((== name) . uniqueModel) (schemaUniques schema)
+ src/Poppy/Codegen/Run.hs view
@@ -0,0 +1,54 @@+module Poppy.Codegen.Run+  ( GenOutput (..),+    allOutputs,+    checkOutputs,+    writeOutputs,+    schemasForTargets,+  )+where++import Data.Text (Text, strip)+import qualified Data.Text.IO as TIO+import Poppy.Codegen.IR (Schema)+import Poppy.Codegen.Target+  ( CodegenTarget,+    GenOutput (..),+    targetOutputs,+    targetSchemas,+  )+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.FilePath (takeDirectory, (</>))++schemasForTargets :: [CodegenTarget] -> [Schema]+schemasForTargets = targetSchemas++allOutputs :: [CodegenTarget] -> [GenOutput]+allOutputs = concatMap targetOutputs++writeOutputs :: FilePath -> [CodegenTarget] -> IO ()+writeOutputs root targets = mapM_ (writeOutput root) (allOutputs targets)++checkOutputs :: FilePath -> [CodegenTarget] -> IO [FilePath]+checkOutputs root targets = filterMismatches root (allOutputs targets)++writeOutput :: FilePath -> GenOutput -> IO ()+writeOutput root GenOutput {outputPath = path, outputText = text} = do+  let fullPath = root </> path+  createDirectoryIfMissing True (takeDirectory fullPath)+  TIO.writeFile fullPath text++filterMismatches :: FilePath -> [GenOutput] -> IO [FilePath]+filterMismatches root = foldr go (pure [])+  where+    go GenOutput {outputPath = path, outputText = expected} acc = do+      mismatches <- acc+      let fullPath = root </> path+      exists <- doesFileExist fullPath+      if not exists+        then pure (path : mismatches)+        else do+          actual <- TIO.readFile fullPath+          pure (if stripText actual == stripText expected then mismatches else path : mismatches)++stripText :: Text -> Text+stripText = strip
+ src/Poppy/Codegen/Schema.hs view
@@ -0,0 +1,158 @@+-- | Table and column names default from Haskell names (@Task@ → @task@, @createdAt@ → @created_at@).+--+-- Application Schemas live in a codegen executable and are passed to+-- 'Poppy.Codegen.CLI.generate'. Field types, relations, and uniques are+-- documented in the repository @docs/schema.md@.+module Poppy.Codegen.Schema+  ( Schema,+    schema,+    Model,+    model,+    table,+    FieldSpec,+    FieldType (..),+    FieldDefault (..),+    uuid,+    text,+    int,+    numeric,+    jsonb,+    bool,+    timestamptz,+    enumField,+    pk,+    nullable,+    updatedAt,+    withDefault,+    column,+    (&),+    RelationSpec,+    RelationKind (..),+    JoinKind (..),+    hasMany,+    belongsTo,+    EnumSpec (..),+    EnumVariant (..),+    enum_,+    enumImportFrom,+    variant,+    variantMap,+    UniqueConstraint (..),+    unique_,+  )+where++import Data.Function ((&))+import Data.Text (Text)+import Poppy.Codegen.IR+  ( EnumSpec (..),+    EnumVariant (..),+    FieldDefault (..),+    FieldSpec (..),+    FieldType (..),+    JoinKind (..),+    Model (..),+    RelationKind (..),+    RelationSpec (..),+    Schema (..),+    UniqueConstraint (..),+    enumImportFrom,+    enum_,+    nullable,+    pk,+    unique_,+    updatedAt,+    variant,+    variantMap,+  )+import qualified Poppy.Codegen.IR as IR+import Poppy.Codegen.TextUtil (camelToSnake)++-- | Application-side default (@Maybe@ on create) and a drift requirement:+-- the SQL migration must set the matching column @DEFAULT@.+--+-- * 'DefaultUuidV4' → @uuid_generate_v4()@ or @gen_random_uuid()@+-- * 'DefaultNow' → @now()@ or @CURRENT_TIMESTAMP@+withDefault :: FieldDefault -> FieldSpec -> FieldSpec+withDefault = IR.withDefault++-- | Enums, models, and uniques.+schema :: [EnumSpec] -> [Model] -> [UniqueConstraint] -> Schema+schema enums models uniques =+  Schema+    { schemaEnums = enums,+      schemaModels = models,+      schemaUniques = uniques+    }++-- | @model \"Task\" fields relations@. Table name defaults to snake_case of the model name.+model :: Text -> [FieldSpec] -> [RelationSpec] -> Model+model name fields rels =+  Model+    { modelName = name,+      modelTable = camelToSnake name,+      modelFields = fields,+      modelRelations = map bind rels+    }+  where+    bind rel = rel {relFromModel = name}++-- | Override the Postgres table name (@model \"Task\" … & table \"tasks\"@).+table :: Text -> Model -> Model+table name m = m {modelTable = name}++-- | @uuid@ column. Haskell type @UUID@.+uuid :: Text -> FieldSpec+uuid = typedField IR.TyUuid++-- | @text@ column. Haskell type @Text@.+text :: Text -> FieldSpec+text = typedField IR.TyText++-- | @integer@ column. Haskell type @Int@.+int :: Text -> FieldSpec+int = typedField IR.TyInt++-- | @numeric@ column. Haskell type @Scientific@.+numeric :: Text -> FieldSpec+numeric = typedField IR.TyNumeric++-- | @jsonb@ column. Haskell type 'Data.Aeson.Value'.+jsonb :: Text -> FieldSpec+jsonb = typedField IR.TyJsonb++-- | @boolean@ column.+bool :: Text -> FieldSpec+bool = typedField IR.TyBool++-- | @timestamptz@ column. Haskell type @UTCTime@.+timestamptz :: Text -> FieldSpec+timestamptz = typedField IR.TyTimestamptz++-- | Postgres enum declared with 'enum_'.+enumField :: Text -> Text -> FieldSpec+enumField name enumName = typedField (IR.TyEnum enumName) name++typedField :: IR.FieldType -> Text -> FieldSpec+typedField ty name =+  IR.field name ty & column (camelToSnake name)++-- | Override the Postgres column name (@text \"title\" & column \"heading\"@).+column :: Text -> FieldSpec -> FieldSpec+column = IR.column++-- | @hasMany \"posts\" \"Post\" \"authorId\"@: the other table's @authorId@ points at this model's PK.+-- The include and nested-write field is that relation name (@posts@).+-- Include values are @skip@, @load@, or @loadWith@ on a nested include.+-- Record-update @where_@, @orderBy_@, and @take_@ on @load@ or @loadWith@+-- to filter that relation. @take_@ is per parent.+hasMany ::+  Text ->+  Text ->+  Text ->+  RelationSpec+hasMany name toModel = IR.hasMany name "" toModel "id"++-- | @belongsTo \"author\" \"Author\" \"authorId\"@: this model's @authorId@ points at @Author@'s PK.+belongsTo :: Text -> Text -> Text -> RelationSpec+belongsTo name toModel foreignFld = IR.belongsTo name "" toModel foreignFld "id"
+ src/Poppy/Codegen/Target.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Target+  ( simpleTarget,+    CodegenTarget,+    GenOutput (..),+    targetOutputs,+    targetSchemas,+  )+where++import Data.Char (isAlphaNum, isUpper)+import Data.Maybe (isNothing)+import Data.Text (Text)+import qualified Data.Text as T+import Poppy.Codegen.Emit.Client+  ( emitClientModule,+  )+import Poppy.Codegen.Emit.Include (emitIncludeModule)+import Poppy.Codegen.Emit.Schema (emitEnumModule, emitModelModule)+import Poppy.Codegen.IR+  ( EnumSpec (..),+    Model (..),+    Schema (..),+    enumImport,+    enumName,+    modelName,+    modelRelations,+    schemaEnums,+    schemaModels,+  )+import System.FilePath (dropTrailingPathSeparator, splitDirectories, (</>))++-- | Path is relative to the process working directory.+data GenOutput = GenOutput+  { outputPath :: FilePath,+    outputText :: Text+  }++data SchemaLayout = SchemaLayout+  { slModulePrefix :: Text,+    slOutputDir :: FilePath+  }++data ClientLayout = ClientLayout+  { clModulePrefix :: Text,+    clOutputDir :: FilePath+  }++data CodegenTarget = CodegenTarget+  { ctSchemas :: [Schema],+    ctLayout :: SchemaLayout,+    ctClientLayout :: ClientLayout+  }++-- | Table types at @Prefix.Model@, clients at @Prefix.Client.Model@.+--+-- @Prefix@ is the path with non-module segments dropped (@src/Schema@ →+-- @Schema@).+simpleTarget :: FilePath -> Schema -> CodegenTarget+simpleTarget dir schema =+  let prefix = prefixFromDir dir+   in CodegenTarget+        { ctSchemas = [schema],+          ctLayout = SchemaLayout (prefix <> ".") dir,+          ctClientLayout =+            ClientLayout+              { clModulePrefix = prefix <> ".Client.",+                clOutputDir = dir </> "Client"+              }+        }++prefixFromDir :: FilePath -> Text+prefixFromDir dir =+  case filter isModuleSegment (map T.pack (splitDirectories (dropTrailingPathSeparator dir))) of+    [] ->+      error $+        "simpleTarget: "+          <> dir+          <> " has no Haskell module segment (e.g. src/Schema)"+    parts -> T.intercalate "." parts++isModuleSegment :: Text -> Bool+isModuleSegment name =+  case T.uncons name of+    Just (c, rest) -> isUpper c && T.all isModuleChar rest+    Nothing -> False++isModuleChar :: Char -> Bool+isModuleChar c = isAlphaNum c || c == '_' || c == '\''++targetSchemas :: [CodegenTarget] -> [Schema]+targetSchemas = concatMap (.ctSchemas)++targetOutputs :: CodegenTarget -> [GenOutput]+targetOutputs target =+  concatMap (schemaOutputs target) target.ctSchemas++schemaOutputs :: CodegenTarget -> Schema -> [GenOutput]+schemaOutputs target schema =+  enumOutputs target schema+    ++ modelOutputs target schema+    ++ includeOutputs target schema+    ++ clientOutputs target schema++enumOutputs :: CodegenTarget -> Schema -> [GenOutput]+enumOutputs target schema =+  concat+    [ enumOutput target enum+      | enum <- schemaEnums schema,+        isNothing (enumImport enum)+    ]++enumOutput :: CodegenTarget -> EnumSpec -> [GenOutput]+enumOutput target enum =+  let layout = target.ctLayout+      name = enumName enum+      moduleName = layout.slModulePrefix <> name+      path = layout.slOutputDir </> T.unpack name <> ".hs"+   in [gen path (emitEnumModule moduleName enum)]++modelOutputs :: CodegenTarget -> Schema -> [GenOutput]+modelOutputs target schema =+  concatMap (modelOutput target schema) (schemaModels schema)++modelOutput :: CodegenTarget -> Schema -> Model -> [GenOutput]+modelOutput target schema model =+  let layout = target.ctLayout+      name = modelName model+      moduleName = layout.slModulePrefix <> name+      path = layout.slOutputDir </> T.unpack name <> ".hs"+   in [gen path (emitModelModule moduleName schema model)]++includeOutputs :: CodegenTarget -> Schema -> [GenOutput]+includeOutputs target schema =+  concatMap (includeOutput target schema) (filter (not . null . modelRelations) (schemaModels schema))++includeOutput :: CodegenTarget -> Schema -> Model -> [GenOutput]+includeOutput target schema model =+  let layout = target.ctLayout+      name = modelName model+      moduleName = layout.slModulePrefix <> "Include." <> name+      path = layout.slOutputDir </> "Include" </> T.unpack name <> ".hs"+   in [gen path (emitIncludeModule moduleName schema model)]++clientOutputs :: CodegenTarget -> Schema -> [GenOutput]+clientOutputs target schema =+  concatMap (clientOutput target.ctClientLayout schema) (schemaModels schema)++clientOutput :: ClientLayout -> Schema -> Model -> [GenOutput]+clientOutput layout schema model =+  let name = modelName model+      moduleName = layout.clModulePrefix <> name+      path = layout.clOutputDir </> T.unpack name <> ".hs"+   in [gen path (emitClientModule moduleName schema model)]++gen :: FilePath -> Text -> GenOutput+gen path text = GenOutput {outputPath = path, outputText = text}
+ src/Poppy/Codegen/TextUtil.hs view
@@ -0,0 +1,28 @@+module Poppy.Codegen.TextUtil+  ( lowerFirst,+    upperFirst,+    camelToSnake,+  )+where++import Data.Char (isUpper, toLower, toUpper)+import Data.Text (Text)+import qualified Data.Text as T++lowerFirst :: Text -> Text+lowerFirst t = case T.uncons t of+  Nothing -> t+  Just (c, rest) -> T.cons (toLower c) rest++upperFirst :: Text -> Text+upperFirst t = case T.uncons t of+  Nothing -> t+  Just (c, rest) -> T.cons (toUpper c) rest++camelToSnake :: Text -> Text+camelToSnake =+  T.dropWhile (== '_') . T.concatMap step+  where+    step c+      | isUpper c = T.pack ['_', toLower c]+      | otherwise = T.singleton c
+ src/Poppy/Codegen/Validate.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Validate+  ( ValidationError (..),+    validateSchema,+  )+where++import Data.List (find, nub)+import Data.Maybe (catMaybes, isNothing)+import Data.Text (Text)+import Poppy.Codegen.IR++data ValidationError+  = DuplicateModelName Text+  | DuplicateEnumName Text+  | EnumHasNoVariants Text+  | DuplicateEnumVariant Text Text+  | UnknownEnumType Text Text Text+  | ModelMissingPrimaryKey Text+  | ModelMultiplePrimaryKeys Text+  | UnknownRelationModel Text Text Text+  | UnknownRelationField Text Text Text+  | DuplicateRelationName Text Text+  | RelationNameClashesWithField Text Text+  | UnknownUniqueModel Text+  | UnknownUniqueField Text Text+  | EmptyUniqueConstraint Text+  deriving (Show, Eq)++validateSchema :: Schema -> [ValidationError]+validateSchema schema =+  concat+    [ duplicateModelNames schema,+      duplicateEnumNames schema,+      concatMap validateEnum (schemaEnums schema),+      concatMap (validateModel schema) (schemaModels schema),+      concatMap (validateRelation schema) (concatMap modelRelations (schemaModels schema)),+      concatMap (validateUnique schema) (schemaUniques schema)+    ]++duplicateModelNames :: Schema -> [ValidationError]+duplicateModelNames schema =+  map DuplicateModelName (duplicates (map modelName (schemaModels schema)))++duplicateEnumNames :: Schema -> [ValidationError]+duplicateEnumNames schema =+  map DuplicateEnumName (duplicates (map enumName (schemaEnums schema)))++validateEnum :: EnumSpec -> [ValidationError]+validateEnum enumSpec =+  let emptyErr =+        [EnumHasNoVariants (enumName enumSpec) | null (enumVariants enumSpec)]+      dupVars =+        map+          (DuplicateEnumVariant (enumName enumSpec))+          (duplicates (map variantName (enumVariants enumSpec)))+   in emptyErr ++ dupVars++validateModel :: Schema -> Model -> [ValidationError]+validateModel schema model =+  let pks = filter fieldIsPrimaryKey (modelFields model)+      pkErrs = case pks of+        [] -> [ModelMissingPrimaryKey (modelName model)]+        [_] -> []+        _ -> [ModelMultiplePrimaryKeys (modelName model)]+      enumErrs = concatMap (validateFieldEnum schema (modelName model)) (modelFields model)+   in pkErrs ++ enumErrs ++ validateRelationNames model++validateRelationNames :: Model -> [ValidationError]+validateRelationNames model =+  map (DuplicateRelationName (modelName model)) (duplicates (map relName (modelRelations model)))+    ++ [ RelationNameClashesWithField (modelName model) name+         | rel <- modelRelations model,+           let name = relName rel,+           any ((== name) . fieldName) (modelFields model)+       ]++validateFieldEnum :: Schema -> Text -> FieldSpec -> [ValidationError]+validateFieldEnum schema modelName fieldSpec =+  case fieldType fieldSpec of+    TyEnum wanted ->+      ([UnknownEnumType modelName (fieldName fieldSpec) wanted | not (any ((== wanted) . enumName) (schemaEnums schema))])+    _ -> []++validateRelation :: Schema -> RelationSpec -> [ValidationError]+validateRelation schema rel =+  let fromOk = findModel schema (relFromModel rel)+      toOk = findModel schema (relToModel rel)+      modelErrs =+        catMaybes+          [ if isNothing fromOk+              then Just (UnknownRelationModel (relName rel) "from" (relFromModel rel))+              else Nothing,+            if isNothing toOk+              then Just (UnknownRelationModel (relName rel) "to" (relToModel rel))+              else Nothing+          ]+      fieldErrs = case (fromOk, toOk, relKind rel) of+        (Just fromModel, Just toModel, RelHasMany) ->+          requireField (relName rel) (modelName fromModel) (relLocalField rel) fromModel+            ++ requireField (relName rel) (modelName toModel) (relForeignField rel) toModel+        (Just fromModel, Just toModel, RelBelongsTo) ->+          requireField (relName rel) (modelName fromModel) (relForeignField rel) fromModel+            ++ requireField (relName rel) (modelName toModel) (relLocalField rel) toModel+        _ -> []+   in modelErrs ++ fieldErrs++findModel :: Schema -> Text -> Maybe Model+findModel schema name =+  find ((== name) . modelName) (schemaModels schema)++validateUnique :: Schema -> UniqueConstraint -> [ValidationError]+validateUnique schema UniqueConstraint {uniqueModel, uniqueFields} =+  case findModel schema uniqueModel of+    Nothing ->+      [UnknownUniqueModel uniqueModel]+    Just model+      | null uniqueFields ->+          [EmptyUniqueConstraint uniqueModel]+      | otherwise ->+          [ UnknownUniqueField uniqueModel wanted+            | wanted <- uniqueFields,+              not (any ((== wanted) . fieldName) (modelFields model))+          ]++requireField :: Text -> Text -> Text -> Model -> [ValidationError]+requireField relName modelName wantedField model =+  [UnknownRelationField relName modelName wantedField | not (any ((== wantedField) . fieldName) (modelFields model))]++duplicates :: (Eq a) => [a] -> [a]+duplicates xs = nub [x | x <- xs, length (filter (== x) xs) > 1]
+ test/Poppy/Codegen/DriftSpec.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.DriftSpec+  ( driftSpec,+    driftDbSpec,+  )+where++import Data.Function ((&))+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Text (Text)+import Poppy.Codegen.Drift+import Poppy.Codegen.IR (FieldDefault (..), Schema (..), schemaUniques)+import Poppy.Codegen.Introspect (canonicalizeColumnType, introspectCatalog)+import qualified Poppy.Codegen.Schema as Builder+import Poppy.Codegen.Spec.Author (authorSchema)+import Poppy.Codegen.Spec.Flag (flagSchema)+import Poppy.Codegen.Spec.Packet (packetSchema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Poppy.Codegen.Spec.Widget (widgetSchema)+import Poppy.Internal.Db (withConn)+import Support.TestDb (TestEnv (..))+import Test.Hspec++driftSpec :: Spec+driftSpec =+  describe "Poppy.Codegen.Drift" $ do+    it "accepts an IR that matches the catalog" $+      checkSchema widgetSchema (widgetCatalog False) `shouldBe` []++    it "reports a missing table" $+      checkSchema widgetSchema emptyCatalog+        `shouldBe` [DriftMissingTable "Widget" "test_widget"]++    it "reports nullability drift" $+      checkSchema widgetSchema (widgetCatalog True)+        `shouldBe` [DriftNullability "test_widget" "name" False True]++    it "reports a missing unique from the IR" $+      checkSchema widgetSchema widgetCatalogWithoutUnique+        `shouldBe` [DriftMissingUnique "test_widget" ["name"]]++    it "reports a database unique that is not in the IR" $+      checkSchema widgetSchemaWithoutNameUnique (widgetCatalog False)+        `shouldBe` [DriftUnexpectedUnique "test_widget" ["name"]]++    it "reports enum label drift" $+      checkSchema colorSchema colorCatalogWrongLabels+        `shouldBe` [DriftEnumLabels "Color" ["blue", "green", "red"] ["blue", "red"]]++    it "accepts a boolean column that matches the catalog" $+      checkSchema flagSchema flagCatalog `shouldBe` []++    it "reports type drift on a boolean column" $+      checkSchema flagSchema flagCatalogAsText+        `shouldBe` [DriftType "flag" "active" "boolean" "text"]++    it "canonicalizes Postgres boolean to the IR boolean type" $+      canonicalizeColumnType "boolean" "bool" `shouldBe` "boolean"++    it "canonicalizes Postgres numeric and jsonb" $ do+      canonicalizeColumnType "numeric" "numeric" `shouldBe` "numeric"+      canonicalizeColumnType "jsonb" "jsonb" `shouldBe` "jsonb"++    it "accepts numeric and jsonb columns that match the catalog" $+      checkSchema packetSchema packetCatalog `shouldBe` []++    it "reports type drift on a numeric column" $+      checkSchema packetSchema packetCatalogAmountAsInt+        `shouldBe` [DriftType "test_packet" "amount" "numeric" "int"]++    it "reports a missing column DEFAULT" $+      checkSchema widgetSchema (widgetCatalogWithoutIdDefault)+        `shouldBe` [DriftMissingDefault "test_widget" "id" DefaultUuidV4]++    it "reports a mismatched column DEFAULT" $+      checkSchema widgetSchema (widgetCatalogWithNowOnId)+        `shouldBe` [DriftDefaultMismatch "test_widget" "id" DefaultUuidV4 "now()"]++    it "reports a missing foreign key implied by belongsTo" $+      checkSchema authorSchema authorCatalogNoFk+        `shouldBe` [DriftMissingForeignKey "test_post" "author_id" "test_author" "id"]++    it "reports a missing foreign key implied by hasMany" $+      checkSchema shelfSchema (shelfCatalogNoFk)+        `shouldBe` [ DriftMissingForeignKey "test_book" "shelf_id" "test_shelf" "id",+                     DriftMissingForeignKey "test_tag" "shelf_id" "test_shelf" "id",+                     DriftMissingForeignKey "test_chapter" "book_id" "test_book" "id",+                     DriftMissingForeignKey "test_section" "chapter_id" "test_chapter" "id"+                   ]++driftDbSpec :: SpecWith TestEnv+driftDbSpec =+  describe "Poppy.Codegen.Drift against Postgres" $ do+    it "matches widget, shelf, author, and packet IR to the test database" $ \TestEnv {envPool = pool} -> do+      catalog <- withConn pool introspectCatalog+      checkSchema widgetSchema catalog `shouldBe` []+      checkSchema shelfSchema catalog `shouldBe` []+      checkSchema authorSchema catalog `shouldBe` []+      checkSchema packetSchema catalog `shouldBe` []++widgetSchemaWithoutNameUnique :: Schema+widgetSchemaWithoutNameUnique =+  widgetSchema {schemaUniques = []}++widgetCatalog :: Bool -> DbCatalog+widgetCatalog nameNullable =+  emptyCatalog+    { dbTables =+        Map.singleton+          "test_widget"+          DbTable+            { dbTableName = "test_widget",+              dbColumns =+                Map.fromList+                  [ col "id" "uuid" False (Just "uuid_generate_v4()"),+                    col "created_at" "timestamptz" False (Just "CURRENT_TIMESTAMP"),+                    col "updated_at" "timestamptz" False (Just "CURRENT_TIMESTAMP"),+                    col "name" "text" nameNullable Nothing,+                    col "description" "text" True Nothing+                  ],+              dbPrimaryKey = ["id"],+              dbUniques = [Set.singleton "name"]+            }+    }++widgetCatalogWithoutUnique :: DbCatalog+widgetCatalogWithoutUnique =+  let base = widgetCatalog False+      table = dbTables base Map.! "test_widget"+   in base {dbTables = Map.singleton "test_widget" table {dbUniques = []}}++widgetCatalogWithoutIdDefault :: DbCatalog+widgetCatalogWithoutIdDefault =+  setWidgetIdDefault Nothing++widgetCatalogWithNowOnId :: DbCatalog+widgetCatalogWithNowOnId =+  setWidgetIdDefault (Just "now()")++setWidgetIdDefault :: Maybe Text -> DbCatalog+setWidgetIdDefault mDefault =+  let base = widgetCatalog False+      table = dbTables base Map.! "test_widget"+      idCol = dbColumns table Map.! "id"+   in base+        { dbTables =+            Map.singleton+              "test_widget"+              table {dbColumns = Map.insert "id" idCol {dbColDefault = mDefault} (dbColumns table)}+        }++colorSchema :: Schema+colorSchema =+  Builder.schema+    [Builder.enum_ "Color" [Builder.variant "red", Builder.variant "blue", Builder.variant "green"]]+    [ Builder.model+        "Swatch"+        [ Builder.uuid "id" & Builder.pk,+          Builder.enumField "color" "Color"+        ]+        []+    ]+    []++colorCatalogWrongLabels :: DbCatalog+colorCatalogWrongLabels =+  emptyCatalog+    { dbEnums = Map.singleton "color" ["red", "blue"],+      dbTables =+        Map.singleton+          "swatch"+          DbTable+            { dbTableName = "swatch",+              dbColumns =+                Map.fromList+                  [ col "id" "uuid" False Nothing,+                    col "color" "enum:color" False Nothing+                  ],+              dbPrimaryKey = ["id"],+              dbUniques = []+            }+    }++flagCatalog :: DbCatalog+flagCatalog =+  emptyCatalog+    { dbTables =+        Map.singleton+          "flag"+          DbTable+            { dbTableName = "flag",+              dbColumns =+                Map.fromList+                  [ col "id" "uuid" False (Just "uuid_generate_v4()"),+                    col "active" "boolean" False Nothing+                  ],+              dbPrimaryKey = ["id"],+              dbUniques = []+            }+    }++flagCatalogAsText :: DbCatalog+flagCatalogAsText =+  let table = dbTables flagCatalog Map.! "flag"+      active = dbColumns table Map.! "active"+   in flagCatalog+        { dbTables =+            Map.singleton+              "flag"+              table {dbColumns = Map.insert "active" active {dbColType = "text"} (dbColumns table)}+        }++packetCatalog :: DbCatalog+packetCatalog =+  emptyCatalog+    { dbTables =+        Map.singleton+          "test_packet"+          DbTable+            { dbTableName = "test_packet",+              dbColumns =+                Map.fromList+                  [ col "id" "uuid" False (Just "uuid_generate_v4()"),+                    col "amount" "numeric" False Nothing,+                    col "payload" "jsonb" False Nothing+                  ],+              dbPrimaryKey = ["id"],+              dbUniques = []+            }+    }++packetCatalogAmountAsInt :: DbCatalog+packetCatalogAmountAsInt =+  let table = dbTables packetCatalog Map.! "test_packet"+      amount = dbColumns table Map.! "amount"+   in packetCatalog+        { dbTables =+            Map.singleton+              "test_packet"+              table {dbColumns = Map.insert "amount" amount {dbColType = "int"} (dbColumns table)}+        }++col :: Text -> Text -> Bool -> Maybe Text -> (Text, DbColumn)+col name ty isNullable mDefault =+  ( name,+    DbColumn+      { dbColName = name,+        dbColType = ty,+        dbColNullable = isNullable,+        dbColDefault = mDefault+      }+  )++authorCatalogNoFk :: DbCatalog+authorCatalogNoFk =+  emptyCatalog+    { dbTables =+        Map.fromList+          [ ( "test_author",+              DbTable+                { dbTableName = "test_author",+                  dbColumns =+                    Map.fromList+                      [ col "id" "uuid" False (Just "uuid_generate_v4()"),+                        col "name" "text" False Nothing+                      ],+                  dbPrimaryKey = ["id"],+                  dbUniques = []+                }+            ),+            ( "test_post",+              DbTable+                { dbTableName = "test_post",+                  dbColumns =+                    Map.fromList+                      [ col "id" "uuid" False (Just "uuid_generate_v4()"),+                        col "author_id" "uuid" False Nothing,+                        col "title" "text" False Nothing,+                        col "status" "enum:poststatus" False Nothing+                      ],+                  dbPrimaryKey = ["id"],+                  dbUniques = []+                }+            )+          ],+      dbEnums = Map.singleton "poststatus" ["draft", "published"]+    }++shelfCatalogNoFk :: DbCatalog+shelfCatalogNoFk =+  emptyCatalog+    { dbTables =+        Map.fromList+          [ table "test_shelf" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "name" "text" False Nothing],+            table "test_book" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "shelf_id" "uuid" False Nothing, col "title" "text" False Nothing],+            table "test_chapter" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "book_id" "uuid" False Nothing, col "heading" "text" False Nothing],+            table "test_section" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "chapter_id" "uuid" False Nothing, col "label" "text" False Nothing],+            table "test_tag" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "shelf_id" "uuid" False Nothing, col "label" "text" False Nothing]+          ]+    }+  where+    table name columns =+      ( name,+        DbTable+          { dbTableName = name,+            dbColumns = Map.fromList columns,+            dbPrimaryKey = ["id"],+            dbUniques = []+          }+      )
+ test/Poppy/Codegen/EmitClientSpec.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.EmitClientSpec+  ( emitClientSpec,+  )+where++import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Poppy.Codegen.Emit.Client+  ( emitClientModule,+    emitSimpleClientModule,+  )+import Poppy.Codegen.IR+  ( modelName,+    schemaModels,+  )+import Poppy.Codegen.Schema+  ( FieldDefault (..),+    Schema,+    hasMany,+    model,+    nullable,+    pk,+    schema,+    text,+    timestamptz,+    uuid,+    withDefault,+    (&),+  )+import Poppy.Codegen.Spec.Example (exampleSchema, taskModel)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Test.Hspec++emitClientSpec :: Spec+emitClientSpec =+  describe "Poppy.Codegen.Emit.Client" $ do+    it "emits Client for the canonical Example Task model" $ do+      let actual = emitSimpleClientModule "Poppy.Client.Task" exampleSchema taskModel+      actual `shouldSatisfy` T.isInfixOf "data TaskQuery"+      actual `shouldSatisfy` T.isInfixOf "findMany :: TaskQuery"+      actual `shouldSatisfy` T.isInfixOf "findFirst :: TaskQuery"+      actual `shouldSatisfy` T.isInfixOf "count :: TaskQuery"+      actual `shouldSatisfy` T.isInfixOf "createMany ::"+      actual `shouldSatisfy` T.isInfixOf "updateMany ::"+      actual `shouldSatisfy` T.isInfixOf "upsert ::"+      actual `shouldSatisfy` T.isInfixOf "emptyQuery"+      actual `shouldSatisfy` T.isInfixOf "data TaskUniqueQuery"+      actual `shouldSatisfy` T.isInfixOf "uniqueQuery ::"++    it "emits Shelf Client with include_ and writes" $ do+      expected <- TIO.readFile "test/Poppy/Codegen/golden/ShelfReadClient.hs.golden"+      let shelf = head [m | m <- schemaModels shelfSchema, modelName m == "Shelf"]+          actual = emitClientModule "Schema.Client.Shelf" shelfSchema shelf+      T.strip actual `shouldBe` T.strip expected+      actual `shouldSatisfy` T.isInfixOf "create ::"+      actual `shouldSatisfy` T.isInfixOf "createMany ::"+      actual `shouldSatisfy` T.isInfixOf "updateMany ::"+      actual `shouldSatisfy` T.isInfixOf "upsert ::"+      actual `shouldSatisfy` T.isInfixOf "data BookNestedCreate"+      actual `shouldSatisfy` T.isInfixOf "data BooksUpdate"+      actual `shouldSatisfy` T.isInfixOf "replaceWith ::"+      actual `shouldSatisfy` T.isInfixOf "ShelfCreateScalars"+      actual `shouldSatisfy` T.isInfixOf "include_ :: include"+      actual `shouldSatisfy` T.isInfixOf "include_ :: include"++    it "imports root scalar types on nested-write Clients" $ do+      let recipe = head [m | m <- schemaModels recipeNestedSchema, modelName m == "Recipe"]+          actual = emitClientModule "Schema.Client.Recipe" recipeNestedSchema recipe+      actual `shouldSatisfy` T.isInfixOf "import Data.Time (UTCTime)"+      actual `shouldSatisfy` T.isInfixOf "NullableValue (..)"+      actual `shouldSatisfy` T.isInfixOf "createdAt :: Maybe UTCTime"+      actual `shouldSatisfy` T.isInfixOf "description :: NullableValue Text"++-- Parent with hasMany plus root timestamptz / nullable text (Recipe-shaped).+recipeNestedSchema :: Schema+recipeNestedSchema =+  schema+    []+    [ model+        "Recipe"+        [ uuid "id" & pk & withDefault DefaultUuidV4,+          timestamptz "createdAt" & withDefault DefaultNow,+          text "title",+          text "description" & nullable+        ]+        [hasMany "steps" "Step" "recipeId"],+      model+        "Step"+        [ uuid "id" & pk & withDefault DefaultUuidV4,+          uuid "recipeId",+          text "body"+        ]+        []+    ]+    []
+ test/Poppy/Codegen/EmitIncludeSpec.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.EmitIncludeSpec+  ( emitIncludeSpec,+  )+where++import qualified Data.Text as T+import Poppy.Codegen.Emit.Include (emitIncludeModule)+import Poppy.Codegen.IR (modelName, schemaModels)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Test.Hspec++emitIncludeSpec :: Spec+emitIncludeSpec =+  describe "Poppy.Codegen.Emit.Include" $ do+    it "emits one Shelf include module with uniform edges" $ do+      let shelf = head [m | m <- schemaModels shelfSchema, modelName m == "Shelf"]+          actual = emitIncludeModule "Schema.Include.Shelf" shelfSchema shelf+      actual `shouldSatisfy` T.isInfixOf "module Schema.Include.Shelf"+      actual `shouldSatisfy` T.isInfixOf "data ShelfInclude books tags"+      actual `shouldSatisfy` T.isInfixOf "ShelfBooks Skip = Skipped \"books\""+      actual `shouldSatisfy` T.isInfixOf "Load BookTable"+      actual `shouldSatisfy` T.isInfixOf "edge.where_"+      actual `shouldSatisfy` T.isInfixOf "edge.take_"+      actual `shouldSatisfy` T.isInfixOf "loadShelf"+      actual `shouldSatisfy` T.isInfixOf "IncludeFor \"Shelf\""
+ test/Poppy/Codegen/EmitSpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.EmitSpec+  ( emitSpec,+  )+where++import Data.List (find)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Poppy.Codegen.Emit.Schema (emitModelModule)+import Poppy.Codegen.IR+  ( Model (..),+    modelName,+    schemaModels,+  )+import Poppy.Codegen.Spec.Example (exampleSchema, taskModel)+import Poppy.Codegen.Spec.Flag (flagModel, flagSchema)+import Poppy.Codegen.Spec.Packet (packetModel, packetSchema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Poppy.Codegen.Spec.Widget (widgetModel, widgetSchema)+import Test.Hspec++emitSpec :: Spec+emitSpec = do+  describe "Poppy.Codegen.Emit.Schema" $ do+    it "emits the canonical Example Task module" $ do+      let actual = emitModelModule "Schema.Task" exampleSchema taskModel+      actual `shouldSatisfy` T.isInfixOf "data TaskRow"+      actual `shouldSatisfy` T.isInfixOf "done :: Bool"+      actual `shouldSatisfy` T.isInfixOf "tableName = \"task\""++    it "emits Widget matching the golden file" $ do+      expected <- T.readFile "test/Poppy/Codegen/golden/Widget.hs.golden"+      let actual = emitModelModule "Schema.Widget" widgetSchema widgetModel+      T.strip actual `shouldBe` T.strip expected++    it "emits Flag matching the golden file" $ do+      expected <- T.readFile "test/Poppy/Codegen/golden/Flag.hs.golden"+      let actual = emitModelModule "Schema.Flag" flagSchema flagModel+      T.strip actual `shouldBe` T.strip expected++    it "emits Packet matching the golden file" $ do+      expected <- T.readFile "test/Poppy/Codegen/golden/Packet.hs.golden"+      let actual = emitModelModule "Schema.Packet" packetSchema packetModel+      T.strip actual `shouldBe` T.strip expected++    it "emits Shelf matching the golden file" $ do+      expected <- T.readFile "test/Poppy/Codegen/golden/Shelf.hs.golden"+      let actual = emitModelModule "Schema.Shelf" shelfSchema shelfModel+      T.strip actual `shouldBe` T.strip expected++    it "emits Book matching the golden file" $ do+      expected <- T.readFile "test/Poppy/Codegen/golden/Book.hs.golden"+      let actual = emitModelModule "Schema.Book" shelfSchema bookModel+      T.strip actual `shouldBe` T.strip expected++    it "emits Chapter matching the golden file" $ do+      expected <- T.readFile "test/Poppy/Codegen/golden/Chapter.hs.golden"+      let actual = emitModelModule "Schema.Chapter" shelfSchema chapterModel+      T.strip actual `shouldBe` T.strip expected++shelfModel :: Model+shelfModel =+  case find ((== "Shelf") . modelName) (schemaModels shelfSchema) of+    Just m -> m+    Nothing -> error "shelfModel: Shelf missing"++bookModel :: Model+bookModel =+  case find ((== "Book") . modelName) (schemaModels shelfSchema) of+    Just m -> m+    Nothing -> error "bookModel: Book missing"++chapterModel :: Model+chapterModel =+  case find ((== "Chapter") . modelName) (schemaModels shelfSchema) of+    Just m -> m+    Nothing -> error "chapterModel: Chapter missing"
+ test/Poppy/Codegen/SchemaSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.SchemaSpec+  ( schemaSpec,+  )+where++import Poppy.Codegen.IR (modelName, modelRelations, relName, schemaModels)+import Poppy.Codegen.Schema+import Poppy.Codegen.Spec.Editor (editorSchema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Test.Hspec++schemaSpec :: Spec+schemaSpec =+  describe "Poppy.Codegen.Schema" $ do+    it "keeps relation names as declared" $ do+      let parent =+            model+              "Parent"+              [uuid "id" & pk]+              [hasMany "kids" "Kid" "parentId"]+          child =+            model+              "Kid"+              [uuid "id" & pk, uuid "parentId"]+              []+          built = schema [] [parent, child] []+          parentModel = head (schemaModels built)+      map relName (modelRelations parentModel) `shouldBe` ["kids"]++    it "derives Shelf relations from the model" $ do+      let shelf = head [m | m <- schemaModels shelfSchema, modelName m == "Shelf"]+      map relName (modelRelations shelf) `shouldBe` ["books", "tags"]++    it "keeps two relations to the same model as distinct edges" $ do+      let editor = head [m | m <- schemaModels editorSchema, modelName m == "Editor"]+      map relName (modelRelations editor) `shouldBe` ["writtenPosts", "editedPosts"]
+ test/Poppy/Codegen/Spec/Author.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Author+  ( authorSchema,+    authorModel,+    postModel,+  )+where++import Poppy.Codegen.Schema++authorSchema :: Schema+authorSchema =+  schema+    [enum_ "PostStatus" [variant "Draft", variant "Published"]]+    [authorModel, postModel]+    []++authorModel :: Model+authorModel =+  model+    "Author"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      text "name"+    ]+    [hasMany "posts" "Post" "authorId"]+    & table "test_author"++postModel :: Model+postModel =+  model+    "Post"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "authorId",+      text "title",+      enumField "status" "PostStatus"+    ]+    [belongsTo "author" "Author" "authorId"]+    & table "test_post"
+ test/Poppy/Codegen/Spec/Comment.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Comment+  ( commentSchema,+  )+where++import Poppy.Codegen.Schema++-- A comment can include its replies, and each reply can include its own.+commentSchema :: Schema+commentSchema =+  schema+    []+    [ commentModel+    ]+    []++commentModel :: Model+commentModel =+  model+    "Comment"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "parentId" & nullable,+      text "body"+    ]+    [hasMany "replies" "Comment" "parentId"]+    & table "test_comment"
+ test/Poppy/Codegen/Spec/Editor.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Editor+  ( editorSchema,+  )+where++import Poppy.Codegen.Schema++-- Two hasMany edges from one model to the same model. The names are the+-- include fields, so both relations compile.+editorSchema :: Schema+editorSchema =+  schema+    []+    [editorModel, articleModel]+    []++editorModel :: Model+editorModel =+  model+    "Editor"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      text "name"+    ]+    [ hasMany "writtenPosts" "Article" "authorId",+      hasMany "editedPosts" "Article" "authorId"+    ]+    & table "test_editor"++articleModel :: Model+articleModel =+  model+    "Article"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "authorId",+      text "title"+    ]+    []+    & table "test_article"
+ test/Poppy/Codegen/Spec/Example.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Example+  ( taskModel,+    exampleSchema,+  )+where++import Poppy.Codegen.Schema++exampleSchema :: Schema+exampleSchema =+  schema [] [taskModel] []++taskModel :: Model+taskModel =+  model+    "Task"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      timestamptz "createdAt" & withDefault DefaultNow,+      timestamptz "updatedAt" & withDefault DefaultNow & updatedAt,+      text "title",+      bool "done"+    ]+    []
+ test/Poppy/Codegen/Spec/Flag.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Flag+  ( flagModel,+    flagSchema,+  )+where++import Poppy.Codegen.Schema++flagSchema :: Schema+flagSchema =+  schema [] [flagModel] []++flagModel :: Model+flagModel =+  model+    "Flag"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      bool "active"+    ]+    []
+ test/Poppy/Codegen/Spec/Packet.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Packet+  ( packetModel,+    packetSchema,+  )+where++import Poppy.Codegen.Schema++packetSchema :: Schema+packetSchema =+  schema [] [packetModel] []++packetModel :: Model+packetModel =+  model+    "Packet"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      numeric "amount",+      jsonb "payload"+    ]+    []+    & table "test_packet"
+ test/Poppy/Codegen/Spec/Shelf.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Shelf+  ( shelfSchema,+  )+where++import Poppy.Codegen.Schema++shelfSchema :: Schema+shelfSchema =+  schema+    []+    [shelfModel, bookModel, chapterModel, sectionModel, tagModel]+    []++shelfModel :: Model+shelfModel =+  model+    "Shelf"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      text "name"+    ]+    [ hasMany "books" "Book" "shelfId",+      hasMany "tags" "Tag" "shelfId"+    ]+    & table "test_shelf"++bookModel :: Model+bookModel =+  model+    "Book"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "shelfId",+      text "title"+    ]+    [hasMany "chapters" "Chapter" "bookRef"]+    & table "test_book"++chapterModel :: Model+chapterModel =+  model+    "Chapter"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "bookRef" & column "book_id",+      text "heading"+    ]+    [hasMany "sections" "Section" "chapterRef"]+    & table "test_chapter"++sectionModel :: Model+sectionModel =+  model+    "Section"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "chapterRef" & column "chapter_id",+      text "label"+    ]+    []+    & table "test_section"++tagModel :: Model+tagModel =+  model+    "Tag"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      uuid "shelfId",+      text "label"+    ]+    []+    & table "test_tag"
+ test/Poppy/Codegen/Spec/ShelfDeep.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.ShelfDeep+  ( shelfDeepSchema,+  )+where++import Poppy.Codegen.IR (Schema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)++-- Same models as Shelf; includes are derived from relations only.+shelfDeepSchema :: Schema+shelfDeepSchema = shelfSchema
+ test/Poppy/Codegen/Spec/Widget.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.Spec.Widget+  ( widgetModel,+    widgetSchema,+  )+where++import Poppy.Codegen.Schema++widgetSchema :: Schema+widgetSchema =+  schema [] [widgetModel] [unique_ "Widget" ["name"]]++widgetModel :: Model+widgetModel =+  model+    "Widget"+    [ uuid "id" & pk & withDefault DefaultUuidV4,+      timestamptz "createdAt" & withDefault DefaultNow,+      timestamptz "updatedAt" & withDefault DefaultNow & updatedAt,+      text "name",+      text "description" & nullable+    ]+    []+    & table "test_widget"
+ test/Poppy/Codegen/TargetSpec.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.TargetSpec+  ( targetSpec,+  )+where++import Data.List (nub, sort)+import qualified Data.Text as T+import Poppy.Codegen.Run (allOutputs, schemasForTargets)+import Poppy.Codegen.Spec.Author (authorSchema)+import Poppy.Codegen.Spec.Comment (commentSchema)+import Poppy.Codegen.Spec.Editor (editorSchema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Poppy.Codegen.Spec.Widget (widgetSchema)+import Poppy.Codegen.Target+  ( CodegenTarget,+    GenOutput (..),+    simpleTarget,+    targetOutputs,+  )+import Poppy.Codegen.TestTarget (testTargets)+import Test.Hspec++allTargets :: [CodegenTarget]+allTargets = testTargets++schemaGoldenNames :: [FilePath]+schemaGoldenNames =+  [ "Article",+    "Author",+    "Book",+    "Chapter",+    "Comment",+    "Editor",+    "Include/Author",+    "Include/Book",+    "Include/Chapter",+    "Include/Comment",+    "Include/Editor",+    "Include/Post",+    "Include/Shelf",+    "Post",+    "PostStatus",+    "Section",+    "Shelf",+    "Tag",+    "Widget"+  ]++targetSpec :: Spec+targetSpec =+  describe "Poppy.Codegen.Target" $ do+    it "validates every schema referenced by a target" $ do+      schemasForTargets allTargets+        `shouldMatchList` [ widgetSchema,+                            shelfSchema,+                            authorSchema,+                            editorSchema,+                            commentSchema+                          ]++    it "writes table types under the output dir and clients under Client/" $ do+      let paths = sort (nub (map outputPath (allOutputs allTargets)))+      filter (not . isClientPath) paths+        `shouldBe` sort+          [ "test/Schema/Article.hs",+            "test/Schema/Author.hs",+            "test/Schema/Book.hs",+            "test/Schema/Chapter.hs",+            "test/Schema/Comment.hs",+            "test/Schema/Editor.hs",+            "test/Schema/Include/Author.hs",+            "test/Schema/Include/Book.hs",+            "test/Schema/Include/Chapter.hs",+            "test/Schema/Include/Comment.hs",+            "test/Schema/Include/Editor.hs",+            "test/Schema/Include/Post.hs",+            "test/Schema/Include/Shelf.hs",+            "test/Schema/Post.hs",+            "test/Schema/PostStatus.hs",+            "test/Schema/Section.hs",+            "test/Schema/Shelf.hs",+            "test/Schema/Tag.hs",+            "test/Schema/Widget.hs"+          ]+      filter isClientPath paths+        `shouldNotBe` []++    it "keeps generated schema modules byte-stable" $ do+      mapM_ assertGoldenStable schemaGoldenNames++    it "emits one Client per model" $ do+      outputPaths (simpleTarget "src/Schema" shelfSchema)+        `shouldMatchList` [ "src/Schema/Book.hs",+                            "src/Schema/Chapter.hs",+                            "src/Schema/Include/Book.hs",+                            "src/Schema/Include/Chapter.hs",+                            "src/Schema/Include/Shelf.hs",+                            "src/Schema/Section.hs",+                            "src/Schema/Shelf.hs",+                            "src/Schema/Tag.hs",+                            "src/Schema/Client/Book.hs",+                            "src/Schema/Client/Chapter.hs",+                            "src/Schema/Client/Section.hs",+                            "src/Schema/Client/Shelf.hs",+                            "src/Schema/Client/Tag.hs"+                          ]++    it "nests clients under the module prefix" $ do+      let target = simpleTarget "src/Schema" widgetSchema+      outputPaths target+        `shouldMatchList` [ "src/Schema/Widget.hs",+                            "src/Schema/Client/Widget.hs"+                          ]+      outputTextFor "src/Schema/Widget.hs" target+        `shouldSatisfy` ("module Schema.Widget" `T.isInfixOf`)+      outputTextFor "src/Schema/Client/Widget.hs" target+        `shouldSatisfy` ("module Schema.Client.Widget" `T.isInfixOf`)++    it "keeps nested module prefixes from the path" $ do+      outputPaths (simpleTarget "src/MyApp/Schema" widgetSchema)+        `shouldMatchList` [ "src/MyApp/Schema/Widget.hs",+                            "src/MyApp/Schema/Client/Widget.hs"+                          ]+      outputTextFor "src/MyApp/Schema/Widget.hs" (simpleTarget "src/MyApp/Schema" widgetSchema)+        `shouldSatisfy` ("module MyApp.Schema.Widget" `T.isInfixOf`)+  where+    isClientPath path = "/Client/" `T.isInfixOf` T.pack path++    assertGoldenStable name = do+      expected <- readFile ("test/Poppy/Codegen/golden/" <> name <> ".hs.golden")+      let path = "test/Schema/" <> name <> ".hs"+          actual =+            T.unpack $+              outputText $+                head+                  [ out+                    | out <- allOutputs allTargets,+                      outputPath out == path+                  ]+      actual `shouldBe` expected++    outputPaths target = map outputPath (targetOutputs target)++    outputTextFor path target =+      outputText $+        head+          [ out+            | out <- targetOutputs target,+              outputPath out == path+          ]
+ test/Poppy/Codegen/TestTarget.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.TestTarget+  ( testTargets,+  )+where++import Poppy.Codegen.Spec.Author (authorSchema)+import Poppy.Codegen.Spec.Comment (commentSchema)+import Poppy.Codegen.Spec.Editor (editorSchema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Poppy.Codegen.Spec.Widget (widgetSchema)+import Poppy.Codegen.Target (CodegenTarget, simpleTarget)++testTargets :: [CodegenTarget]+testTargets =+  [ simpleTarget "test/Schema" widgetSchema,+    simpleTarget "test/Schema" shelfSchema,+    simpleTarget "test/Schema" authorSchema,+    simpleTarget "test/Schema" editorSchema,+    simpleTarget "test/Schema" commentSchema+  ]
+ test/Poppy/Codegen/ValidateSpec.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE OverloadedStrings #-}++module Poppy.Codegen.ValidateSpec+  ( validateSpec,+  )+where++import Poppy.Codegen.IR+import qualified Poppy.Codegen.Schema as Builder+import Poppy.Codegen.Spec.Editor (editorSchema)+import Poppy.Codegen.Spec.Example (exampleSchema)+import Poppy.Codegen.Spec.Flag (flagSchema)+import Poppy.Codegen.Spec.Packet (packetSchema)+import Poppy.Codegen.Spec.Shelf (shelfSchema)+import Poppy.Codegen.Validate+import Test.Hspec++emptySchema :: [Model] -> Schema+emptySchema models =+  Schema {schemaEnums = [], schemaModels = models, schemaUniques = []}++validateSpec :: Spec+validateSpec =+  describe "Poppy.Codegen.Validate" $ do+    describe "example specs" $ do+      it "accepts the Shelf schema" $+        validateSchema shelfSchema `shouldBe` []++      it "accepts the canonical Example schema" $+        validateSchema exampleSchema `shouldBe` []++      it "accepts a Schema with a boolean field" $+        validateSchema flagSchema `shouldBe` []++      it "accepts a Schema with numeric and jsonb fields" $+        validateSchema packetSchema `shouldBe` []++      it "rejects a builder model with no primary key" $+        validateSchema (Builder.schema [] [Builder.model "Widget" [text "name"] []] [])+          `shouldBe` [ModelMissingPrimaryKey "Widget"]++    describe "primary keys" $ do+      it "rejects a model with no primary key" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Widget",+                      modelTable = "widget",+                      modelFields = [text "name"],+                      modelRelations = []+                    }+                ]+        validateSchema schema+          `shouldBe` [ModelMissingPrimaryKey "Widget"]++      it "rejects a model with multiple primary keys" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Widget",+                      modelTable = "widget",+                      modelFields = [pk (uuid "id"), pk (uuid "otherId")],+                      modelRelations = []+                    }+                ]+        validateSchema schema+          `shouldBe` [ModelMultiplePrimaryKeys "Widget"]++    describe "enums" $ do+      it "rejects a field referencing an unknown enum" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Item",+                      modelTable = "item",+                      modelFields = [pk (uuid "id"), enumField "unit" "Unit"],+                      modelRelations = []+                    }+                ]+        validateSchema schema+          `shouldBe` [UnknownEnumType "Item" "unit" "Unit"]++      it "rejects an enum with no variants" $ do+        let schema =+              Schema+                { schemaEnums = [enum_ "Unit" []],+                  schemaModels =+                    [ Model+                        { modelName = "Item",+                          modelTable = "item",+                          modelFields = [pk (uuid "id")],+                          modelRelations = []+                        }+                    ],+                  schemaUniques = []+                }+        validateSchema schema+          `shouldBe` [EnumHasNoVariants "Unit"]++      it "rejects duplicate enum variant names" $ do+        let schema =+              Schema+                { schemaEnums = [enum_ "Unit" [variant "G", variant "G"]],+                  schemaModels =+                    [ Model+                        { modelName = "Item",+                          modelTable = "item",+                          modelFields = [pk (uuid "id")],+                          modelRelations = []+                        }+                    ],+                  schemaUniques = []+                }+        validateSchema schema+          `shouldBe` [DuplicateEnumVariant "Unit" "G"]++    describe "relations" $ do+      it "rejects a relation pointing at an unknown model" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Shelf",+                      modelTable = "test_shelf",+                      modelFields = [pk (uuid "id")],+                      modelRelations =+                        [ hasMany "shelfBooks" "Shelf" "Missing" "id" "shelfId"+                        ]+                    }+                ]+        validateSchema schema+          `shouldBe` [UnknownRelationModel "shelfBooks" "to" "Missing"]++      it "rejects a relation with an unknown field" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Shelf",+                      modelTable = "test_shelf",+                      modelFields = [pk (uuid "id")],+                      modelRelations =+                        [ hasMany "shelfBooks" "Shelf" "Book" "id" "shelfId"+                        ]+                    },+                  Model+                    { modelName = "Book",+                      modelTable = "test_book",+                      modelFields = [pk (uuid "id"), text "title"],+                      modelRelations = []+                    }+                ]+        validateSchema schema+          `shouldBe` [UnknownRelationField "shelfBooks" "Book" "shelfId"]++      it "rejects a relation name used twice on one model" $ do+        let schema =+              Builder.schema+                []+                [ Builder.model+                    "Author"+                    [pk (uuid "id"), text "name"]+                    [ Builder.hasMany "posts" "Post" "authorId",+                      Builder.hasMany "posts" "Post" "authorId"+                    ],+                  Builder.model+                    "Post"+                    [pk (uuid "id"), uuid "authorId", text "title"]+                    []+                ]+                []+        validateSchema schema+          `shouldBe` [ DuplicateRelationName "Author" "posts"+                     ]++      it "rejects a relation name equal to a scalar field" $ do+        let schema =+              Builder.schema+                []+                [ Builder.model+                    "Author"+                    [pk (uuid "id"), text "name"]+                    [Builder.hasMany "name" "Post" "authorId"],+                  Builder.model+                    "Post"+                    [pk (uuid "id"), uuid "authorId"]+                    []+                ]+                []+        validateSchema schema+          `shouldBe` [RelationNameClashesWithField "Author" "name"]++      it "accepts two relations from one model to the same model" $ do+        validateSchema editorSchema `shouldBe` []++    describe "uniques" $ do+      it "rejects a unique constraint on an unknown model" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Widget",+                      modelTable = "widget",+                      modelFields = [pk (uuid "id")],+                      modelRelations = []+                    }+                ]+            drifted = schema {schemaUniques = [unique_ "Nope" ["id"]]}+        validateSchema drifted+          `shouldBe` [UnknownUniqueModel "Nope"]++      it "rejects a unique constraint that references an unknown field" $ do+        let schema =+              emptySchema+                [ Model+                    { modelName = "Widget",+                      modelTable = "widget",+                      modelFields = [pk (uuid "id")],+                      modelRelations = []+                    }+                ]+            drifted = schema {schemaUniques = [unique_ "Widget" ["name"]]}+        validateSchema drifted+          `shouldBe` [UnknownUniqueField "Widget" "name"]
+ test/Poppy/Codegen/golden/Article.hs.golden 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/Poppy/Codegen/golden/Author.hs.golden 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/Poppy/Codegen/golden/Book.hs.golden 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/Poppy/Codegen/golden/Chapter.hs.golden 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/Poppy/Codegen/golden/Comment.hs.golden 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/Poppy/Codegen/golden/Editor.hs.golden 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/Poppy/Codegen/golden/Flag.hs.golden view
@@ -0,0 +1,136 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeApplications #-}++module Schema.Flag+  ( FlagTable (..),+    FlagRow (..),+    FlagSelect (..),+    FlagPicked (..),+    flagSelect,+    flagSelectColumns,+    parseFlagPicked,+    toFlagPicked,+    FlagCreate (..),+    FlagUpdate (..),+    flagId,+    flagActive+  )+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 FlagTable = FlagTable++type instance PrimaryKeyType FlagTable = UUID++type instance ModelTable "Flag" = FlagTable++instance Entity FlagTable where+  tableName = "flag"+  primaryKey = flagId+  tableColumns = ["id", "active"]++instance Insertable FlagTable where+  type CreateInput FlagTable = FlagCreate+  toInsertBuilder input =+    setMaybe flagId input.id $+      set flagActive input.active $+      emptyInsert @FlagTable+++instance Updatable FlagTable where+  type UpdateInput FlagTable = FlagUpdate+  updatedAtField = Nothing+  toUpdateBuilder input =+    setFieldMaybe flagActive input.active $+      emptyUpdate @FlagTable+++data FlagRow = FlagRow+  { id :: UUID,+    active :: Bool+  }+  deriving (Show, Eq)+++data FlagCreate = FlagCreate+  { id :: Maybe UUID,+    active :: Bool+  }+  deriving (Show, Eq)+++data FlagUpdate = FlagUpdate+  { active :: Maybe Bool+  }+  deriving (Show, Eq)+++instance FromRow FlagRow where+  fromRow = FlagRow <$> field <*> field+++data FlagSelect = FlagSelect+  { id :: Bool,+    active :: Bool+  }+  deriving (Show, Eq)+data FlagPicked = FlagPicked+  { id :: UUID,+    active :: Picked Bool+  }+  deriving (Show, Eq)+flagSelect :: FlagSelect+flagSelect =+  FlagSelect+    { id = False,+      active = False+    }+flagSelectColumns :: FlagSelect -> [Text]+flagSelectColumns select_ =+  fieldColumn flagId+    : concat+      [ [fieldColumn flagActive | select_.active]+      ]+parseFlagPicked :: FlagSelect -> RowParser FlagPicked+parseFlagPicked select_ = do+  idVal <- field+  activeVal <- if select_.active then Picked <$> field else pure Skipped+  pure FlagPicked { id = idVal, active = activeVal }+toFlagPicked :: FlagSelect -> FlagRow -> FlagPicked+toFlagPicked select_ row =+  FlagPicked+    { id = row.id,+      active = picked select_.active row.active+    }+++flagId :: Field FlagTable UUID+flagId = Field "id" "id"++flagActive :: Field FlagTable Bool+flagActive = Field "active" "active"+
+ test/Poppy/Codegen/golden/Packet.hs.golden 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/Poppy/Codegen/golden/Post.hs.golden 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/Poppy/Codegen/golden/PostStatus.hs.golden 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/Poppy/Codegen/golden/Section.hs.golden 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/Poppy/Codegen/golden/Shelf.hs.golden 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/Poppy/Codegen/golden/ShelfReadClient.hs.golden 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/Poppy/Codegen/golden/Tag.hs.golden 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/Poppy/Codegen/golden/Widget.hs.golden 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,22 @@+module Main (main) where++import Poppy.Codegen.DriftSpec (driftDbSpec, driftSpec)+import Poppy.Codegen.EmitClientSpec (emitClientSpec)+import Poppy.Codegen.EmitIncludeSpec (emitIncludeSpec)+import Poppy.Codegen.EmitSpec (emitSpec)+import Poppy.Codegen.SchemaSpec (schemaSpec)+import Poppy.Codegen.TargetSpec (targetSpec)+import Poppy.Codegen.ValidateSpec (validateSpec)+import Support.TestDb (withTestDb)+import Test.Hspec++main :: IO ()+main = hspec $ do+  schemaSpec+  validateSpec+  emitSpec+  emitIncludeSpec+  emitClientSpec+  targetSpec+  driftSpec+  withTestDb driftDbSpec
+ test/Support/TestDb.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeApplications #-}++module Support.TestDb+  ( TestEnv (..),+    withTestDb,+    testDatabaseUrl,+  )+where++import Control.Exception (SomeException, displayException, try)+import Poppy.Internal.Db (DbPool, closePool, connect)+import Support.TestMigrations (runTestMigrations)+import System.Environment (lookupEnv)+import Test.Hspec (Spec, SpecWith, afterAll, beforeAll)++newtype TestEnv = TestEnv+  { envPool :: DbPool+  }++withTestDb :: SpecWith TestEnv -> Spec+withTestDb spec =+  beforeAll setupTestEnv $+    afterAll destroyTestEnv 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
+ 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/009-test-widget-name-unique.sql view
@@ -0,0 +1,1 @@+ALTER TABLE test_widget ADD CONSTRAINT test_widget_name_key UNIQUE (name);