From c6a674996fb8c9935ececc0bf94c004a7690aa27 Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:07 -0600 Subject: [PATCH 01/11] feat: Support GHC-9.10. --- .github/workflows/haskell.yml | 138 ++++++++++++++++++---------------- cabal.project | 3 + cabal.project.freeze | 125 ++++++++++++++++-------------- squeal-postgresql-qq.cabal | 4 +- 4 files changed, 145 insertions(+), 125 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 9ac4e10..80916a9 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -9,11 +9,12 @@ jobs: matrix: ghc-version: - '9.8' - cabal-version: ['3.10.2.0'] + - '9.10' + cabal-version: ['3.12.1.0'] steps: # Checkout - uses: actions/checkout@v3 - + # Setup - name: Setup Haskell uses: haskell-actions/setup@v2 @@ -27,7 +28,7 @@ jobs: - name: Configure the Build run: | rm cabal.project.freeze - cabal configure + cabal configure --enable-tests --disable-optimization cabal build --dry-run # Restore cache @@ -55,74 +56,79 @@ jobs: # Cabal build - name: Cabal Bulid run: | - project="$(cat cabal.project | grep -v -- '-Werror')" - echo "$project" > cabal.project cabal build all - # build-lower-bounds: - # name: Haskell Build (lower bounds) - # runs-on: ubuntu-latest # or macOS-latest, or windows-latest - # strategy: - # fail-fast: false - # matrix: - # ghc-version: ['9.8.1'] - # cabal-version: ['3.10.2.0'] - # steps: - # # Checkout - # - uses: actions/checkout@v3 - # - # # Setup - # - name: Setup Haskell - # uses: haskell-actions/setup@v2 - # id: setup - # if: steps.tooling-cache.outputs.cache-hit != 'true' - # with: - # ghc-version: ${{ matrix.ghc-version }} - # cabal-version: ${{ matrix.cabal-version }} + # Cabal tests + - name: Cabal Test + run: | + cabal test all + + build-lower-bounds: + name: Haskell Build (lower bounds) + runs-on: ubuntu-latest # or macOS-latest, or windows-latest + strategy: + fail-fast: false + matrix: + ghc-version: ['9.8.1'] + cabal-version: ['3.12.1.0'] + steps: + # Checkout + - uses: actions/checkout@v3 + + # Setup + - name: Setup Haskell + uses: haskell-actions/setup@v2 + id: setup + if: steps.tooling-cache.outputs.cache-hit != 'true' + with: + ghc-version: ${{ matrix.ghc-version }} + cabal-version: ${{ matrix.cabal-version }} - # # Generate Plan - # - name: Configure the Build - # run: | - # (cat << EOF - # packages: . - # constraints: - # base == 4.19.0.0, - # generics-sop == 0.5.1.4, - # hspec == 2.11.7, - # simple-sql-parser == 0.6.0, - # squeal-postgresql == 0.9.1.3, - # template-haskell == 2.21.0.0, - # text == 2.1, - # uuid == 1.3.15 - # EOF - # ) > cabal.project - # rm cabal.project.freeze - # cabal configure - # cabal build --dry-run + # Generate Plan + - name: Configure the Build + run: | + (cat << EOF + packages: . + constraints: + base == 4.19.0.0, + generics-sop == 0.5.1.4, + hspec == 2.11.7, + simple-sql-parser == 0.6.0, + squeal-postgresql == 0.9.1.3, + template-haskell == 2.21.0.0, + text == 2.1, + uuid == 1.3.15 + ) > cabal.project + rm cabal.project.freeze + cabal configure --enable-tests --disable-optimization + cabal build --dry-run - # # Restore cache - # - name: Restore cached dependencies - # uses: actions/cache/restore@v3 - # id: cache - # env: - # key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} - # with: - # path: ${{ steps.setup.outputs.cabal-store }} - # key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} + # Restore cache + - name: Restore cached dependencies + uses: actions/cache/restore@v3 + id: cache + env: + key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} - # # Build deps (for caching) - # - name: Cabal build dependencies - # run: cabal build all --only-dependencies + # Build deps (for caching) + - name: Cabal build dependencies + run: cabal build all --only-dependencies - # # Save dependency cache - # - name: Save cache - # uses: actions/cache/save@v3 - # if: steps.cache.outputs.cache-hit != 'true' - # with: - # path: ${{ steps.setup.outputs.cabal-store }} - # key: ${{ steps.cache.outputs.cache-primary-key }} + # Save dependency cache + - name: Save cache + uses: actions/cache/save@v3 + if: steps.cache.outputs.cache-hit != 'true' + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ steps.cache.outputs.cache-primary-key }} - # # Cabal build - # - name: Cabal Bulid - # run: cabal build all + # Cabal Build + - name: Cabal Bulid + run: cabal build all + # Cabal Test + - name: Cabal Test + run: cabal test all diff --git a/cabal.project b/cabal.project index 81e5f41..64eca0d 100644 --- a/cabal.project +++ b/cabal.project @@ -10,3 +10,6 @@ allow-newer: , simple-sql-parser:mtl +constraints: + postgresql-binary == 0.13.1.3 + diff --git a/cabal.project.freeze b/cabal.project.freeze index 2759c46..3e78c8d 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -1,54 +1,56 @@ -active-repositories: hackage.haskell.org:merge, owensmurray:merge -constraints: any.Cabal ==3.10.2.0, - any.Cabal-syntax ==3.10.2.0, +active-repositories: hackage.haskell.org:merge +constraints: any.Cabal ==3.12.0.0, + any.Cabal-syntax ==3.12.0.0, any.HUnit ==1.6.2.0, - any.OneTuple ==0.4.1.1, - any.QuickCheck ==2.14.3, + any.OneTuple ==0.4.2, + any.QuickCheck ==2.15.0.1, QuickCheck -old-random +templatehaskell, any.StateVar ==1.2.2, - any.aeson ==2.2.1.0, + any.aeson ==2.2.3.0, aeson +ordered-keymap, - any.ansi-terminal ==1.0.2, + any.ansi-terminal ==1.1.2, ansi-terminal -example, - any.ansi-terminal-types ==0.11.5, - any.array ==0.5.6.0, - any.assoc ==1.1, - assoc +tagged, + any.ansi-terminal-types ==1.1, + any.array ==0.5.7.0, + any.assoc ==1.1.1, + assoc -tagged, any.async ==2.2.5, async -bench, any.attoparsec ==0.14.4, attoparsec -developer, - any.base ==4.19.0.0, - any.base-orphans ==0.9.1, - any.bifunctors ==5.6.1, + any.base ==4.20.0.0, + any.base-orphans ==0.9.2, + any.bifunctors ==5.6.2, bifunctors +tagged, - any.binary ==0.8.9.1, + any.binary ==0.8.9.2, any.binary-parser ==0.5.7.6, - any.bytestring ==0.12.0.2, + any.bytestring ==0.12.1.0, any.bytestring-strict-builder ==0.4.5.7, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, any.cereal ==0.5.8.3, cereal -bytestring-builder, + any.character-ps ==0.1, any.charset ==0.3.10, any.colour ==2.3.6, any.comonad ==5.0.8, comonad +containers +distributive +indexed-traversable, - any.containers ==0.6.8, + any.containers ==0.7, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, any.cryptohash-md5 ==0.11.101.0, any.cryptohash-sha1 ==0.11.101.0, any.data-bword ==0.1.0.2, any.data-checked ==0.3, - any.data-default-class ==0.1.2.0, + any.data-default ==0.8.0.0, + any.data-default-class ==0.2.0.0, any.data-dword ==0.3.2.1, any.data-endian ==0.1.1, - any.data-fix ==0.3.2, + any.data-fix ==0.3.4, any.data-serializer ==0.3.5, any.data-textual ==0.3.0.3, any.deepseq ==1.5.0.0, - any.directory ==1.3.8.1, + any.directory ==1.3.8.3, any.distributive ==0.6.2.1, distributive +semigroups +tagged, any.dlist ==1.0, @@ -56,25 +58,26 @@ constraints: any.Cabal ==3.10.2.0, any.entropy ==0.4.1.10, entropy -donotgetentropy, any.exceptions ==0.10.7, - any.filepath ==1.4.100.4, + any.filepath ==1.5.2.0, any.free-categories ==0.2.0.2, any.generically ==0.1.1, any.generics-sop ==0.5.1.4, any.ghc-bignum ==1.3, - any.ghc-boot-th ==9.8.1, + any.ghc-boot-th ==9.10.1, + any.ghc-internal ==9.1001.0, any.ghc-prim ==0.11.0, - any.hashable ==1.4.3.0, - hashable +integer-gmp -random-initial-seed, - any.haskell-lexer ==1.1.1, + any.hashable ==1.5.0.0, + hashable -arch-native -random-initial-seed, + any.haskell-lexer ==1.1.2, any.hsc2hs ==0.68.10, hsc2hs -in-ghc-tree, - any.hspec ==2.11.7, - any.hspec-core ==2.11.7, - any.hspec-discover ==2.11.7, + any.hspec ==2.11.10, + any.hspec-core ==2.11.10, + any.hspec-discover ==2.11.10, any.hspec-expectations ==0.8.4, - any.indexed-traversable ==0.1.3, - any.indexed-traversable-instances ==0.1.1.2, - any.integer-conversion ==0.1.0.1, + any.indexed-traversable ==0.1.4, + any.indexed-traversable-instances ==0.1.2, + any.integer-conversion ==0.1.1, any.integer-logarithms ==1.0.3.1, integer-logarithms -check-bounds +integer-gmp, any.mmorph ==1.2.0, @@ -83,27 +86,34 @@ constraints: any.Cabal ==3.10.2.0, any.network-info ==0.2.1, any.network-ip ==0.3.0.3, any.network-uri ==2.6.4.2, + any.optparse-applicative ==0.18.1.0, + optparse-applicative +process, + any.os-string ==2.0.2, any.parsec ==3.1.17.0, - any.parsers ==0.12.11, + any.parsers ==0.12.12, parsers +attoparsec +binary +parsec, any.postgresql-binary ==0.13.1.3, - any.postgresql-libpq ==0.10.0.0, + any.postgresql-libpq ==0.11.0.0, postgresql-libpq -use-pkg-config, + any.postgresql-libpq-configure ==0.11, any.pretty ==1.1.3.6, + any.prettyprinter ==1.7.1, + prettyprinter -buildreadme +text, + any.prettyprinter-ansi-terminal ==1.1.3, any.primitive ==0.9.0.0, - any.process ==1.6.18.0, + any.process ==1.6.19.0, any.profunctors ==5.6.2, any.quickcheck-io ==0.2.0, - any.random ==1.2.1.1, + any.random ==1.2.1.2, any.records-sop ==0.1.1.1, any.resource-pool ==0.4.0.0, any.rts ==1.0.2, any.safe-exceptions ==0.1.7.4, - any.scientific ==0.3.7.0, - scientific -bytestring-builder -integer-simple, - any.semialign ==1.3, + any.scientific ==0.3.8.0, + scientific -integer-simple, + any.semialign ==1.3.1, semialign +semigroupoids, - any.semigroupoids ==6.0.0.1, + any.semigroupoids ==6.0.1, semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, any.semigroups ==0.20, semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, @@ -114,39 +124,40 @@ constraints: any.Cabal ==3.10.2.0, any.splitmix ==0.1.0.5, splitmix -optimised-mixer, any.squeal-postgresql ==0.9.1.3, - any.stm ==2.5.2.1, - any.strict ==0.5, + any.stm ==2.5.3.1, + any.strict ==0.5.1, any.tagged ==0.8.8, tagged +deepseq +transformers, - any.template-haskell ==2.21.0.0, - any.text ==2.1, - any.text-iso8601 ==0.1, + any.tasty ==1.5.2, + tasty +unix, + any.template-haskell ==2.22.0.0, + any.text ==2.1.1, + any.text-iso8601 ==0.1.1, any.text-latin1 ==0.3.1, any.text-printer ==0.5.0.2, - any.text-short ==0.1.5, + any.text-short ==0.1.6, text-short -asserts, any.tf-random ==0.5, - any.th-abstraction ==0.6.0.0, - any.th-compat ==0.1.4, - any.these ==1.2, + any.th-abstraction ==0.7.0.0, + any.th-compat ==0.1.5, + any.these ==1.2.1, any.time ==1.12.2, - any.time-compat ==1.9.6.1, - time-compat -old-locale, - any.transformers ==0.6.1.0, + any.time-compat ==1.9.7, + any.transformers ==0.6.1.1, any.transformers-base ==0.4.6, transformers-base +orphaninstances, any.transformers-compat ==0.7.2, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, any.type-hint ==0.1, - any.unix ==2.8.3.0, + any.unix ==2.8.5.1, any.unliftio ==0.2.25.0, any.unliftio-core ==0.2.1.0, any.unordered-containers ==0.2.20, unordered-containers -debug, - any.uuid ==1.3.15, - any.uuid-types ==1.0.5.1, - any.vector ==0.13.1.0, + any.uuid ==1.3.16, + any.uuid-types ==1.0.6, + any.vector ==0.13.2.0, vector +boundschecks -internalchecks -unsafechecks -wall, any.vector-stream ==0.1.0.1, - any.witherable ==0.4.2 -index-state: hackage.haskell.org 2024-01-22T21:44:21Z + any.witherable ==0.5 +index-state: hackage.haskell.org 2024-11-22T14:59:16Z diff --git a/squeal-postgresql-qq.cabal b/squeal-postgresql-qq.cabal index 52829f6..05937ea 100644 --- a/squeal-postgresql-qq.cabal +++ b/squeal-postgresql-qq.cabal @@ -17,11 +17,11 @@ extra-source-files: common dependencies build-depends: - , base >= 4.19.0.0 && < 4.20 + , base >= 4.19.0.0 && < 4.21 , generics-sop >= 0.5.1.4 && < 0.6 , simple-sql-parser >= 0.6.0 && < 0.7 , squeal-postgresql >= 0.9.1.3 && < 0.10 - , template-haskell >= 2.21.0.0 && < 2.22 + , template-haskell >= 2.21.0.0 && < 2.23 , text >= 2.1 && < 2.2 , uuid >= 1.3.15 && < 1.4 From 41526801cdff32b35e7bf3a44f00b8f0deaaece0 Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:08 -0600 Subject: [PATCH 02/11] no-op: whitespace --- test/test.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/test/test.hs b/test/test.hs index a791bca..4dba9ba 100644 --- a/test/test.hs +++ b/test/test.hs @@ -36,13 +36,16 @@ type UsersConstraints = '[ "pk_users" ::: 'PrimaryKey '["id"] ] type EmailsColumns = '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "user_id" ::: 'NoDef :=> 'NotNull 'PGtext - , "email" ::: 'NoDef :=> 'Null 'PGtext ] + , "email" ::: 'NoDef :=> 'Null 'PGtext + ] type EmailsConstraints = '[ "pk_emails" ::: 'PrimaryKey '["id"] - , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] ] + , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"] + ] type Schema = '[ "users" ::: 'Table (UsersConstraints :=> UsersColumns) - , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) ] + , "emails" ::: 'Table (EmailsConstraints :=> EmailsColumns) + ] type DB = Public Schema From c275faa4f4d5639e3abb9068b886925beadfd127 Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:09 -0600 Subject: [PATCH 03/11] no-op: Update .gitignore ... ... by adding *.full-imports --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 5c6a2ed..9be8fbd 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ /cabal.project.local /.tags.lock /tags +*.full-imports From 526ac4d66a8d611e6d10aa98dd77064111c6905f Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:10 -0600 Subject: [PATCH 04/11] refactor: Create a Common module. ... This commit creates the module `Squeal.QuasiQuotes.Common`, which contains rendering tools that will soon be common to the other main modules such as `Query` and `Insert`, once the `Insert` module is created. --- squeal-postgresql-qq.cabal | 1 + src/Squeal/QuasiQuotes/Common.hs | 65 ++++++++++++++++++++++++++++++++ src/Squeal/QuasiQuotes/Query.hs | 59 +++-------------------------- 3 files changed, 72 insertions(+), 53 deletions(-) create mode 100644 src/Squeal/QuasiQuotes/Common.hs diff --git a/squeal-postgresql-qq.cabal b/squeal-postgresql-qq.cabal index 05937ea..d9c7802 100644 --- a/squeal-postgresql-qq.cabal +++ b/squeal-postgresql-qq.cabal @@ -35,6 +35,7 @@ common warnings common other-modules other-modules: + Squeal.QuasiQuotes.Common Squeal.QuasiQuotes.Query Squeal.QuasiQuotes.RowType diff --git a/src/Squeal/QuasiQuotes/Common.hs b/src/Squeal/QuasiQuotes/Common.hs new file mode 100644 index 0000000..368971d --- /dev/null +++ b/src/Squeal/QuasiQuotes/Common.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| Commonplace renderers shared by other modules. -} +module Squeal.QuasiQuotes.Common ( + renderTableRef, + renderScalarExpr, +) where + + +import Data.List (foldl') +import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE)) +import Language.SQL.SimpleSQL.Syntax (JoinCondition(JoinOn), + JoinType(JLeft), Name(Name), ScalarExpr(BinOp, Iden, Star), + TableRef(TRJoin, TRSimple)) +import Prelude (Bool(False), Maybe(Just, Nothing), Semigroup((<>)), + Show(show), ($), error) +import qualified Squeal.PostgreSQL as S + + +renderTableRef :: TableRef -> Exp +renderTableRef = \case + TRSimple [Name Nothing theTable] -> + VarE 'S.table + `AppE` + ( + VarE 'S.as + `AppE` LabelE theTable + `AppE` LabelE theTable + ) + TRJoin left False JLeft right (Just condition) -> + VarE 'S.leftOuterJoin + `AppE` renderTableRef right + `AppE` renderJoinCondition condition + `AppE` renderTableRef left + unsupported -> + error $ "Unsupported: " <> show unsupported + where + renderJoinCondition = \case + (JoinOn expr) -> + renderScalarExpr expr + unsupported -> + error $ "Unsupported: " <> show unsupported + + +renderScalarExpr :: ScalarExpr -> Exp +renderScalarExpr = \case + Star -> ConE 'S.Star + Iden (Name _ name:more) -> + foldl' + (\acc (Name _ n) -> + VarE '(S.!) `AppE` acc `AppE` LabelE n + ) + (LabelE name) + more + BinOp left [Name Nothing "."] Star -> + ConE 'S.DotStar `AppE` renderScalarExpr left + (BinOp left [Name Nothing "="] right) -> + VarE '(S..==) + `AppE` renderScalarExpr left + `AppE` renderScalarExpr right + unsupported -> + error $ "unsupported: " <> show unsupported + + diff --git a/src/Squeal/QuasiQuotes/Query.hs b/src/Squeal/QuasiQuotes/Query.hs index d43125a..265e88f 100644 --- a/src/Squeal/QuasiQuotes/Query.hs +++ b/src/Squeal/QuasiQuotes/Query.hs @@ -7,15 +7,13 @@ module Squeal.QuasiQuotes.Query ( toSquealQuery, ) where -import Data.List (foldl') import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE), Q) -import Language.SQL.SimpleSQL.Syntax (JoinCondition(JoinOn), - JoinType(JLeft), Name(Name), QueryExpr(Select, qeFrom, qeGroupBy, - qeHaving, qeOffset, qeOrderBy, qeSelectList, qeSetQuantifier, - qeWhere), ScalarExpr(BinOp, Iden, Star), SetQuantifier(SQDefault), - TableRef(TRJoin, TRSimple)) -import Prelude (Applicative(pure), Bool(False), Maybe(Just, Nothing), - MonadFail(fail), Semigroup((<>)), Show(show), ($), error) +import Language.SQL.SimpleSQL.Syntax (Name(Name), QueryExpr(Select, + qeFrom, qeGroupBy, qeHaving, qeOffset, qeOrderBy, qeSelectList, + qeSetQuantifier, qeWhere), SetQuantifier(SQDefault), ScalarExpr) +import Prelude (Applicative(pure), Maybe(Just, Nothing), MonadFail(fail), + Semigroup((<>)), Show(show), ($), error) +import Squeal.QuasiQuotes.Common (renderScalarExpr, renderTableRef) import Squeal.QuasiQuotes.RowType (monoQuery) import qualified Squeal.PostgreSQL as S @@ -54,31 +52,6 @@ toSquealQuery = \case fail $ "Unsupported: " <> show unsupported -renderTableRef :: TableRef -> Exp -renderTableRef = \case - TRSimple [Name Nothing theTable] -> - VarE 'S.table - `AppE` - ( - VarE 'S.as - `AppE` LabelE theTable - `AppE` LabelE theTable - ) - TRJoin left False JLeft right (Just condition) -> - VarE 'S.leftOuterJoin - `AppE` renderTableRef right - `AppE` renderJoinCondition condition - `AppE` renderTableRef left - unsupported -> - error $ "Unsupported: " <> show unsupported - where - renderJoinCondition = \case - (JoinOn expr) -> - renderScalarExpr expr - unsupported -> - error $ "Unsupported: " <> show unsupported - - renderSelectionList :: [(ScalarExpr, Maybe Name)] -> Exp renderSelectionList selectionList = case selectionList of @@ -105,23 +78,3 @@ renderSelectionList selectionList = `AppE` LabelE alias -renderScalarExpr :: ScalarExpr -> Exp -renderScalarExpr = \case - Star -> ConE 'S.Star - Iden (Name _ name:more) -> - foldl' - (\acc (Name _ n) -> - VarE '(S.!) `AppE` acc `AppE` LabelE n - ) - (LabelE name) - more - BinOp left [Name Nothing "."] Star -> - ConE 'S.DotStar `AppE` renderScalarExpr left - (BinOp left [Name Nothing "="] right) -> - VarE '(S..==) - `AppE` renderScalarExpr left - `AppE` renderScalarExpr right - unsupported -> - error $ "unsupported: " <> show unsupported - - From f8f3bc7277e480258493b45b9d8c0ca71a6b8a23 Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:11 -0600 Subject: [PATCH 05/11] no-op: Remove redundant parens. --- src/Squeal/QuasiQuotes/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Squeal/QuasiQuotes/Common.hs b/src/Squeal/QuasiQuotes/Common.hs index 368971d..9b0d09c 100644 --- a/src/Squeal/QuasiQuotes/Common.hs +++ b/src/Squeal/QuasiQuotes/Common.hs @@ -55,7 +55,7 @@ renderScalarExpr = \case more BinOp left [Name Nothing "."] Star -> ConE 'S.DotStar `AppE` renderScalarExpr left - (BinOp left [Name Nothing "="] right) -> + BinOp left [Name Nothing "="] right -> VarE '(S..==) `AppE` renderScalarExpr left `AppE` renderScalarExpr right From 834e7af4a7f99f76634eb297bdd567ffebe464eb Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:12 -0600 Subject: [PATCH 06/11] no-op: Documentation. ... This commit improves the documentation for the RowType type family. --- src/Squeal/QuasiQuotes/RowType.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Squeal/QuasiQuotes/RowType.hs b/src/Squeal/QuasiQuotes/RowType.hs index 8350669..797a8a5 100644 --- a/src/Squeal/QuasiQuotes/RowType.hs +++ b/src/Squeal/QuasiQuotes/RowType.hs @@ -43,7 +43,9 @@ import qualified Squeal.PostgreSQL as Squeal > (Field name1 type1, > (Field name2 type2, > (Field name3 type3, - > ())) + > , + > ()))...) + where the "name" are phantom types of kind `Symbol`, which provide the name of the corresponding column, and types "type" are whatever From 58e69d645ef61578b99969db817f9defcce3e5f5 Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:13 -0600 Subject: [PATCH 07/11] feat: Basic insert. --- squeal-postgresql-qq.cabal | 2 + src/Squeal/QuasiQuotes.hs | 7 ++- src/Squeal/QuasiQuotes/Common.hs | 17 +++++-- src/Squeal/QuasiQuotes/Insert.hs | 82 ++++++++++++++++++++++++++++++++ test/test.hs | 13 +++++ 5 files changed, 116 insertions(+), 5 deletions(-) create mode 100644 src/Squeal/QuasiQuotes/Insert.hs diff --git a/squeal-postgresql-qq.cabal b/squeal-postgresql-qq.cabal index d9c7802..61bf15a 100644 --- a/squeal-postgresql-qq.cabal +++ b/squeal-postgresql-qq.cabal @@ -18,6 +18,7 @@ extra-source-files: common dependencies build-depends: , base >= 4.19.0.0 && < 4.21 + , bytestring >= 0.12.0.2 && < 0.13 , generics-sop >= 0.5.1.4 && < 0.6 , simple-sql-parser >= 0.6.0 && < 0.7 , squeal-postgresql >= 0.9.1.3 && < 0.10 @@ -36,6 +37,7 @@ common warnings common other-modules other-modules: Squeal.QuasiQuotes.Common + Squeal.QuasiQuotes.Insert Squeal.QuasiQuotes.Query Squeal.QuasiQuotes.RowType diff --git a/src/Squeal/QuasiQuotes.hs b/src/Squeal/QuasiQuotes.hs index 0ef8d6f..a8fd297 100644 --- a/src/Squeal/QuasiQuotes.hs +++ b/src/Squeal/QuasiQuotes.hs @@ -16,8 +16,9 @@ import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter, quoteDec, import Language.Haskell.TH.Syntax (Exp, Q, runIO) import Language.SQL.SimpleSQL.Dialect (postgres) import Language.SQL.SimpleSQL.Parse (ParseError, parseStatement) -import Prelude (Either(Left, Right), Maybe(Nothing), MonadFail(fail), - Semigroup((<>)), Show(show), ($), (.), error, print) +import Prelude (Applicative(pure), Either(Left, Right), Maybe(Nothing), + MonadFail(fail), Semigroup((<>)), Show(show), ($), (.), error, print) +import Squeal.QuasiQuotes.Insert (toSquealInsert) import Squeal.QuasiQuotes.Query (toSquealQuery) import Squeal.QuasiQuotes.RowType (Field(Field, unField)) import qualified Language.SQL.SimpleSQL.Syntax as AST @@ -44,6 +45,8 @@ toSqueal = \case toSquealStatement :: AST.Statement -> Q Exp toSquealStatement = \case AST.SelectStatement theQuery -> toSquealQuery theQuery + AST.Insert into fields values -> + pure $ toSquealInsert into fields values unsupported -> error $ "Unsupported: " <> show unsupported diff --git a/src/Squeal/QuasiQuotes/Common.hs b/src/Squeal/QuasiQuotes/Common.hs index 9b0d09c..c7466bf 100644 --- a/src/Squeal/QuasiQuotes/Common.hs +++ b/src/Squeal/QuasiQuotes/Common.hs @@ -9,12 +9,15 @@ module Squeal.QuasiQuotes.Common ( import Data.List (foldl') -import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, VarE)) +import Data.String (IsString(fromString)) +import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, LitE, VarE), + Lit(StringL)) import Language.SQL.SimpleSQL.Syntax (JoinCondition(JoinOn), - JoinType(JLeft), Name(Name), ScalarExpr(BinOp, Iden, Star), - TableRef(TRJoin, TRSimple)) + JoinType(JLeft), Name(Name), ScalarExpr(BinOp, Iden, NumLit, Star, + StringLit), TableRef(TRJoin, TRSimple)) import Prelude (Bool(False), Maybe(Just, Nothing), Semigroup((<>)), Show(show), ($), error) +import qualified Data.ByteString.Char8 as BS8 import qualified Squeal.PostgreSQL as S @@ -59,6 +62,14 @@ renderScalarExpr = \case VarE '(S..==) `AppE` renderScalarExpr left `AppE` renderScalarExpr right + NumLit num -> + ConE 'S.UnsafeExpression + `AppE` ( + VarE 'BS8.pack + `AppE` LitE (StringL num) + ) + StringLit _ _ str -> + VarE 'fromString `AppE` LitE (StringL str) unsupported -> error $ "unsupported: " <> show unsupported diff --git a/src/Squeal/QuasiQuotes/Insert.hs b/src/Squeal/QuasiQuotes/Insert.hs new file mode 100644 index 0000000..d466f16 --- /dev/null +++ b/src/Squeal/QuasiQuotes/Insert.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + + +{-| Description: Translate insert statements. -} +module Squeal.QuasiQuotes.Insert ( + toSquealInsert, +) where + + +import Data.List (foldl') +import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, ListE, VarE)) +import Language.SQL.SimpleSQL.Syntax (InsertSource(InsertQuery), + Name(Name), QueryExpr(Values), Statement(Insert), ScalarExpr) +import Prelude (Maybe(Just, Nothing), Semigroup((<>)), Show(show), ($), + (<$>), error) +import Squeal.QuasiQuotes.Common (renderScalarExpr) +import qualified Squeal.PostgreSQL as S + + +toSquealInsert + :: [Name] + -> Maybe [Name] + -> InsertSource + -> Exp +toSquealInsert into fields values = + VarE 'S.manipulation + `AppE` ( + case (fields, values) of + (Just names, InsertQuery (Values vals)) -> + VarE 'S.insertInto_ + `AppE` renderQualifiedName into + `AppE` renderValueRows names vals + _ -> + error $ "Unspported: " <> show (Insert into fields values) + ) + where + renderQualifiedName :: [Name] -> Exp + renderQualifiedName qualNames = + case renderNameAsLabel <$> qualNames of + [] -> error $ "Unspported: " <> show (Insert into fields values) + first:more -> + foldl' + (\acc n -> + VarE '(S.!) + `AppE` acc + `AppE` n + ) + first + more + + renderNameAsLabel :: Name -> Exp + renderNameAsLabel = \case + Name Nothing name -> LabelE name + unsupported -> error $ "Unsupported: " <> show unsupported + + renderValueRows :: [Name] -> [[ScalarExpr]] -> Exp + renderValueRows names vals = + case vals of + [] -> error "Insert statement has no value rows." + row:more -> + ConE 'S.Values + `AppE` renderValueRow names row + `AppE` ListE (renderValueRow names <$> more) + + renderValueRow :: [Name] -> [ScalarExpr] -> Exp + renderValueRow = + \cases + [] [] -> ConE 'S.Nil + ((Name Nothing name):names) (val:vals) -> + ConE '(S.:*) + `AppE` + ( + VarE 'S.as + `AppE` (ConE 'S.Set `AppE` renderScalarExpr val) + `AppE` LabelE name + ) + `AppE` + renderValueRow names vals + _ _ -> + error "Mismatched number of names and values in insert statement." + diff --git a/test/test.hs b/test/test.hs index 4dba9ba..f21eada 100644 --- a/test/test.hs +++ b/test/test.hs @@ -162,6 +162,19 @@ main = |] printQuery statement + describe "inserts" $ do + it "insert into emails (id, user_id, email) values (1, 'user-1', 'foo@bar')" $ do + let + statement + :: Statement DB () () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (1, 'user-1', 'foo@bar') + |] + printQuery statement + printQuery :: RenderSQL a => a -> IO () printQuery = putStrLn . T.unpack . TE.decodeUtf8 . renderSQL From 6970e176411258f467e35a1dda4dfc7ccf32d59c Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:14 -0600 Subject: [PATCH 08/11] feat: Insert params. --- src/Squeal/QuasiQuotes/Common.hs | 15 ++++++++------ test/test.hs | 34 +++++++++++++++++++++++++++++++- 2 files changed, 42 insertions(+), 7 deletions(-) diff --git a/src/Squeal/QuasiQuotes/Common.hs b/src/Squeal/QuasiQuotes/Common.hs index c7466bf..6dbd5c4 100644 --- a/src/Squeal/QuasiQuotes/Common.hs +++ b/src/Squeal/QuasiQuotes/Common.hs @@ -10,13 +10,13 @@ module Squeal.QuasiQuotes.Common ( import Data.List (foldl') import Data.String (IsString(fromString)) -import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, LitE, VarE), - Lit(StringL)) +import Language.Haskell.TH.Syntax (Exp(AppE, AppTypeE, ConE, LabelE, + LitE, VarE), Lit(StringL), TyLit(NumTyLit), Type(LitT)) import Language.SQL.SimpleSQL.Syntax (JoinCondition(JoinOn), - JoinType(JLeft), Name(Name), ScalarExpr(BinOp, Iden, NumLit, Star, - StringLit), TableRef(TRJoin, TRSimple)) -import Prelude (Bool(False), Maybe(Just, Nothing), Semigroup((<>)), - Show(show), ($), error) + JoinType(JLeft), Name(Name), ScalarExpr(BinOp, Iden, NumLit, + PositionalArg, Star, StringLit), TableRef(TRJoin, TRSimple)) +import Prelude (Bool(False), Integral(toInteger), Maybe(Just, Nothing), + Semigroup((<>)), Show(show), ($), error) import qualified Data.ByteString.Char8 as BS8 import qualified Squeal.PostgreSQL as S @@ -70,6 +70,9 @@ renderScalarExpr = \case ) StringLit _ _ str -> VarE 'fromString `AppE` LitE (StringL str) + PositionalArg n -> + VarE 'S.param + `AppTypeE` LitT (NumTyLit (toInteger n)) unsupported -> error $ "unsupported: " <> show unsupported diff --git a/test/test.hs b/test/test.hs index f21eada..39b8251 100644 --- a/test/test.hs +++ b/test/test.hs @@ -17,7 +17,7 @@ import Prelude (($), (.), IO, Maybe, Show, putStrLn) import Squeal.PostgreSQL (NullType(NotNull, Null), Optionality(Def, NoDef), PGType(PGint4, PGtext, PGuuid), RenderSQL(renderSQL), SchemumType(Table), TableConstraint(ForeignKey, PrimaryKey), (:::), - (:=>), Public, Statement) + (:=>), Only, Public, Statement) import Squeal.QuasiQuotes (Field, ssql) import Test.Hspec (describe, hspec, it) import qualified Data.Text as T @@ -174,6 +174,38 @@ main = values (1, 'user-1', 'foo@bar') |] printQuery statement + it "insert into emails (id, user_id, email) values (1, 'user-1', $1)" $ do + let + statement + :: Statement + DB + (Only (Maybe Text)) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (1, 'user-1', $1) + |] + printQuery statement + it "insert into emails (id, user_id, email) values (1, $2, $1)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + {- + Note the parameters are backwards (i.e. $2 comes before $1), + to test that you can do this kind of thing out of order. + -} + [ssql| + insert into + emails (id, user_id, email) + values (1, $2, $1) + |] + printQuery statement printQuery :: RenderSQL a => a -> IO () From f920e893b8101c2d5b7059c818639988939d716c Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:15 -0600 Subject: [PATCH 09/11] feat: "default" keyword. --- src/Squeal/QuasiQuotes/Insert.hs | 26 ++++++++++++++----- test/test.hs | 43 ++++++++++++++++++++++++++++++++ 2 files changed, 63 insertions(+), 6 deletions(-) diff --git a/src/Squeal/QuasiQuotes/Insert.hs b/src/Squeal/QuasiQuotes/Insert.hs index d466f16..bb947e8 100644 --- a/src/Squeal/QuasiQuotes/Insert.hs +++ b/src/Squeal/QuasiQuotes/Insert.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} - +{-# LANGUAGE ViewPatterns #-} {-| Description: Translate insert statements. -} module Squeal.QuasiQuotes.Insert ( @@ -11,10 +12,11 @@ module Squeal.QuasiQuotes.Insert ( import Data.List (foldl') import Language.Haskell.TH.Syntax (Exp(AppE, ConE, LabelE, ListE, VarE)) import Language.SQL.SimpleSQL.Syntax (InsertSource(InsertQuery), - Name(Name), QueryExpr(Values), Statement(Insert), ScalarExpr) -import Prelude (Maybe(Just, Nothing), Semigroup((<>)), Show(show), ($), - (<$>), error) + Name(Name), QueryExpr(Values), ScalarExpr(Iden), Statement(Insert)) +import Prelude (Functor(fmap), Maybe(Just, Nothing), Semigroup((<>)), + Show(show), ($), (<$>), error) import Squeal.QuasiQuotes.Common (renderScalarExpr) +import qualified Data.Char as Char import qualified Squeal.PostgreSQL as S @@ -29,8 +31,8 @@ toSquealInsert into fields values = case (fields, values) of (Just names, InsertQuery (Values vals)) -> VarE 'S.insertInto_ - `AppE` renderQualifiedName into - `AppE` renderValueRows names vals + `AppE` renderQualifiedName into {- The table name -} + `AppE` renderValueRows names vals {- The values -} _ -> error $ "Unspported: " <> show (Insert into fields values) ) @@ -67,6 +69,18 @@ toSquealInsert into fields values = renderValueRow = \cases [] [] -> ConE 'S.Nil + ((Name Nothing name):names) + (Iden [Name Nothing (fmap Char.toLower -> "default")]:vals) + -> + ConE '(S.:*) + `AppE` + ( + VarE 'S.as + `AppE` ConE 'S.Default + `AppE` LabelE name + ) + `AppE` + renderValueRow names vals ((Name Nothing name):names) (val:vals) -> ConE '(S.:*) `AppE` diff --git a/test/test.hs b/test/test.hs index 39b8251..e1519b5 100644 --- a/test/test.hs +++ b/test/test.hs @@ -206,6 +206,49 @@ main = values (1, $2, $1) |] printQuery statement + describe "default keyword" $ do + it "insert into emails (id, user_id, email) values (default, 'foo', 'bar')" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (default, 'foo', 'bar') + |] + printQuery statement + it "insert into emails (id, user_id, email) values (deFault, 'foo', 'bar')" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (deFault, 'foo', 'bar') + |] + printQuery statement + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', 'bar')" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', 'bar') + |] + printQuery statement printQuery :: RenderSQL a => a -> IO () From b843ad08661b15bc0b68335cdc01b11fe8b6022e Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:16 -0600 Subject: [PATCH 10/11] feat: "null" keyword. --- src/Squeal/QuasiQuotes/Common.hs | 8 ++++-- test/test.hs | 43 ++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 2 deletions(-) diff --git a/src/Squeal/QuasiQuotes/Common.hs b/src/Squeal/QuasiQuotes/Common.hs index 6dbd5c4..0774fc2 100644 --- a/src/Squeal/QuasiQuotes/Common.hs +++ b/src/Squeal/QuasiQuotes/Common.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE ViewPatterns #-} {-| Commonplace renderers shared by other modules. -} module Squeal.QuasiQuotes.Common ( @@ -15,9 +16,10 @@ import Language.Haskell.TH.Syntax (Exp(AppE, AppTypeE, ConE, LabelE, import Language.SQL.SimpleSQL.Syntax (JoinCondition(JoinOn), JoinType(JLeft), Name(Name), ScalarExpr(BinOp, Iden, NumLit, PositionalArg, Star, StringLit), TableRef(TRJoin, TRSimple)) -import Prelude (Bool(False), Integral(toInteger), Maybe(Just, Nothing), - Semigroup((<>)), Show(show), ($), error) +import Prelude (Bool(False), Functor(fmap), Integral(toInteger), + Maybe(Just, Nothing), Semigroup((<>)), Show(show), ($), error) import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Char as Char import qualified Squeal.PostgreSQL as S @@ -49,6 +51,8 @@ renderTableRef = \case renderScalarExpr :: ScalarExpr -> Exp renderScalarExpr = \case Star -> ConE 'S.Star + Iden [Name Nothing (fmap Char.toLower -> "null")] -> + VarE 'S.null_ Iden (Name _ name:more) -> foldl' (\acc (Name _ n) -> diff --git a/test/test.hs b/test/test.hs index e1519b5..3137932 100644 --- a/test/test.hs +++ b/test/test.hs @@ -249,6 +249,49 @@ main = values (DEFAULT, 'foo', 'bar') |] printQuery statement + describe "null keyword" $ do + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', null)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', null) + |] + printQuery statement + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', NULL)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', NULL) + |] + printQuery statement + it "insert into emails (id, user_id, email) values (DEFAULT, 'foo', NuLL)" $ do + let + statement + :: Statement + DB + (Maybe Text, Text) + () + statement = + [ssql| + insert into + emails (id, user_id, email) + values (DEFAULT, 'foo', NuLL) + |] + printQuery statement printQuery :: RenderSQL a => a -> IO () From 693951b5d6e7f0c04e4b64f720c8a04b4847c7a5 Mon Sep 17 00:00:00 2001 From: Rick Owens Date: Sun, 8 Dec 2024 15:02:17 -0600 Subject: [PATCH 11/11] no-op: Update documentation copy. --- src/Squeal/QuasiQuotes/RowType.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Squeal/QuasiQuotes/RowType.hs b/src/Squeal/QuasiQuotes/RowType.hs index 797a8a5..597dddb 100644 --- a/src/Squeal/QuasiQuotes/RowType.hs +++ b/src/Squeal/QuasiQuotes/RowType.hs @@ -10,15 +10,15 @@ {- | Description: Monomorphic squeal row types. - This module creates a type family that converts (via a type family) - a squeal row type into a specific, monomorphic tuple representation - meant to be consumed by the user. The purpose of this so that the squeal - quasiquoter won't produce polymorphic types, though it will produce - a *different* monomorphic type depending on the columns returned by - the query. The reason we want that is to help type inference as much - as possible. Squeal already has some problems with type inference, - and burden on the user of navigating them is only likely to increase - when a lot of the squeal "code" itself is hidden behind a quasiquoter. + This module provides a type family that converts a squeal row type into + a specific, monomorphic tuple representation meant to be consumed by the + user. The purpose of this so that the squeal quasiquoter won't produce + polymorphic types, though it will produce a *different* monomorphic + type depending on the columns returned by the query. The reason we want + this is to help type inference as much as possible. Squeal already + has some problems with type inference, and the burden on the user of + navigating them is only likely to increase when a lot of the squeal + "code" itself is hidden behind a quasiquoter. -} module Squeal.QuasiQuotes.RowType ( RowType,