git.iko.soy/typeable/postgresql-simple
on master help sign in
swap
3ac2949159 ahead, 0 behind
50 files changed+3041−780
since splitsnapshots
unifiedsplit
.ghci−16 .github/workflows/haskell-ci.yml+256 .github/workflows/simple.yml+58 .gitignore+4−1 .travis.yml−76 CHANGES.md+160−5 CONTRIBUTING.md+13 CONTRIBUTORS+1 README.md−3 bench/Select.hs+32 cabal.haskell-ci+5 cabal.project+3 cabal.project.local.win+4 postgresql-simple.cabal+163−119 src/Database/PostgreSQL/Simple.hs+36−119 src/Database/PostgreSQL/Simple/Arrays.hs+2−2 src/Database/PostgreSQL/Simple/Compat.hs−53 src/Database/PostgreSQL/Simple/Copy.hs+32−4 src/Database/PostgreSQL/Simple/Cursor.hs+98 src/Database/PostgreSQL/Simple/Errors.hs+4−3 src/Database/PostgreSQL/Simple/FromField.hs+124−70 src/Database/PostgreSQL/Simple/FromRow.hs+209−2 src/Database/PostgreSQL/Simple/HStore/Implementation.hs+11−11 src/Database/PostgreSQL/Simple/Internal.hs+67−16 src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs+123 src/Database/PostgreSQL/Simple/Newtypes.hs+49 src/Database/PostgreSQL/Simple/Notification.hs−17 src/Database/PostgreSQL/Simple/Ok.hs+7−4 src/Database/PostgreSQL/Simple/Range.hs+14−10 src/Database/PostgreSQL/Simple/SqlQQ.hs+10−9 src/Database/PostgreSQL/Simple/Time.hs+2 src/Database/PostgreSQL/Simple/Time/Implementation.hs+11−1 src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+12−3 src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs+15−3 src/Database/PostgreSQL/Simple/ToField.hs+33−11 src/Database/PostgreSQL/Simple/ToRow.hs+106 src/Database/PostgreSQL/Simple/Transaction.hs+17−13 src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9 src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+9−3 src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+684−114 src/Database/PostgreSQL/Simple/Types.hs+9−25 src/Database/PostgreSQL/Simple/Vector.hs+45 src/Database/PostgreSQL/Simple/Vector/Unboxed.hs+44 test/Exception.hs+70 test/Inspection.hs+79 test/Interval.hs+176 test/Main.hs+194−31 test/Time.hs+1−1 test/results/malformed-input.expected+1−1 tools/GenTypeInfo.hs+39−25
.ghcideleted−16
@@ -1,16 +0,0 @@
1−:set -isrc -itest -optP-includedist/build/autogen/cabal_macros.h
2−:set -Wall -fno-warn-name-shadowing
3−
4−:set -XDoAndIfThenElse
5−:set -XOverloadedStrings
6−:set -XBangPatterns
7−:set -XViewPatterns
8−:set -XTypeOperators
9−
10−-- for tests
11−:set -XNamedFieldPuns
12−:set -XRank2Types
13−:set -XRecordWildCards
14−:set -XPatternGuards
15−:set -XScopedTypeVariables
16−:set -fno-warn-unused-do-bind
.github/workflows/haskell-ci.ymlnew file+256
@@ -0,0 +1,256 @@
1+# This GitHub workflow config has been generated by a script via
2+#
3+# haskell-ci 'github' 'cabal.project'
4+#
5+# To regenerate the script (for example after adjusting tested-with) run
6+#
7+# haskell-ci regenerate
8+#
9+# For more information, see https://github.com/haskell-CI/haskell-ci
10+#
11+# version: 0.17.20231110
12+#
13+# REGENDATA ("0.17.20231110",["github","cabal.project"])
14+#
15+name: Haskell-CI
16+on:
17+ push:
18+ branches:
19+ - master
20+ pull_request:
21+ branches:
22+ - master
23+jobs:
24+ linux:
25+ name: Haskell-CI - Linux - ${{ matrix.compiler }}
26+ runs-on: ubuntu-20.04
27+ timeout-minutes:
28+ 60
29+ container:
30+ image: buildpack-deps:bionic
31+ services:
32+ postgres:
33+ image: postgres:14
34+ env:
35+ POSTGRES_PASSWORD: postgres
36+ options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5
37+ continue-on-error: ${{ matrix.allow-failure }}
38+ strategy:
39+ matrix:
40+ include:
41+ - compiler: ghc-9.8.1
42+ compilerKind: ghc
43+ compilerVersion: 9.8.1
44+ setup-method: ghcup
45+ allow-failure: false
46+ - compiler: ghc-9.6.3
47+ compilerKind: ghc
48+ compilerVersion: 9.6.3
49+ setup-method: ghcup
50+ allow-failure: false
51+ - compiler: ghc-9.4.8
52+ compilerKind: ghc
53+ compilerVersion: 9.4.8
54+ setup-method: ghcup
55+ allow-failure: false
56+ - compiler: ghc-9.2.8
57+ compilerKind: ghc
58+ compilerVersion: 9.2.8
59+ setup-method: ghcup
60+ allow-failure: false
61+ - compiler: ghc-9.0.2
62+ compilerKind: ghc
63+ compilerVersion: 9.0.2
64+ setup-method: ghcup
65+ allow-failure: false
66+ - compiler: ghc-8.10.7
67+ compilerKind: ghc
68+ compilerVersion: 8.10.7
69+ setup-method: ghcup
70+ allow-failure: false
71+ - compiler: ghc-8.8.4
72+ compilerKind: ghc
73+ compilerVersion: 8.8.4
74+ setup-method: hvr-ppa
75+ allow-failure: false
76+ - compiler: ghc-8.6.5
77+ compilerKind: ghc
78+ compilerVersion: 8.6.5
79+ setup-method: hvr-ppa
80+ allow-failure: false
81+ fail-fast: false
82+ steps:
83+ - name: apt
84+ run: |
85+ apt-get update
86+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
87+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
88+ mkdir -p "$HOME/.ghcup/bin"
89+ curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
90+ chmod a+x "$HOME/.ghcup/bin/ghcup"
91+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
92+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
93+ else
94+ apt-add-repository -y 'ppa:hvr/ghc'
95+ apt-get update
96+ apt-get install -y "$HCNAME"
97+ mkdir -p "$HOME/.ghcup/bin"
98+ curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
99+ chmod a+x "$HOME/.ghcup/bin/ghcup"
100+ "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
101+ fi
102+ env:
103+ HCKIND: ${{ matrix.compilerKind }}
104+ HCNAME: ${{ matrix.compiler }}
105+ HCVER: ${{ matrix.compilerVersion }}
106+ - name: Set PATH and environment variables
107+ run: |
108+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH
109+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
110+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
111+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
112+ HCDIR=/opt/$HCKIND/$HCVER
113+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
114+ HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
115+ HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
116+ HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
117+ echo "HC=$HC" >> "$GITHUB_ENV"
118+ echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
119+ echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
120+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
121+ else
122+ HC=$HCDIR/bin/$HCKIND
123+ echo "HC=$HC" >> "$GITHUB_ENV"
124+ echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
125+ echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
126+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
127+ fi
128+
129+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
130+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
131+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
132+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
133+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
134+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
135+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"
136+ env:
137+ HCKIND: ${{ matrix.compilerKind }}
138+ HCNAME: ${{ matrix.compiler }}
139+ HCVER: ${{ matrix.compilerVersion }}
140+ - name: env
141+ run: |
142+ env
143+ - name: write cabal config
144+ run: |
145+ mkdir -p $CABAL_DIR
146+ cat >> $CABAL_CONFIG <<EOF
147+ remote-build-reporting: anonymous
148+ write-ghc-environment-files: never
149+ remote-repo-cache: $CABAL_DIR/packages
150+ logs-dir: $CABAL_DIR/logs
151+ world-file: $CABAL_DIR/world
152+ extra-prog-path: $CABAL_DIR/bin
153+ symlink-bindir: $CABAL_DIR/bin
154+ installdir: $CABAL_DIR/bin
155+ build-summary: $CABAL_DIR/logs/build.log
156+ store-dir: $CABAL_DIR/store
157+ install-dirs user
158+ prefix: $CABAL_DIR
159+ repository hackage.haskell.org
160+ url: http://hackage.haskell.org/
161+ EOF
162+ cat >> $CABAL_CONFIG <<EOF
163+ program-default-options
164+ ghc-options: $GHCJOBS +RTS -M3G -RTS
165+ EOF
166+ cat $CABAL_CONFIG
167+ - name: versions
168+ run: |
169+ $HC --version || true
170+ $HC --print-project-git-commit-id || true
171+ $CABAL --version || true
172+ - name: update cabal index
173+ run: |
174+ $CABAL v2-update -v
175+ - name: install cabal-plan
176+ run: |
177+ mkdir -p $HOME/.cabal/bin
178+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
179+ echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
180+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
181+ rm -f cabal-plan.xz
182+ chmod a+x $HOME/.cabal/bin/cabal-plan
183+ cabal-plan --version
184+ - name: checkout
185+ uses: actions/checkout@v3
186+ with:
187+ path: source
188+ - name: initial cabal.project for sdist
189+ run: |
190+ touch cabal.project
191+ echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
192+ cat cabal.project
193+ - name: sdist
194+ run: |
195+ mkdir -p sdist
196+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
197+ - name: unpack
198+ run: |
199+ mkdir -p unpacked
200+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
201+ - name: generate cabal.project
202+ run: |
203+ PKGDIR_postgresql_simple="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/postgresql-simple-[0-9.]*')"
204+ echo "PKGDIR_postgresql_simple=${PKGDIR_postgresql_simple}" >> "$GITHUB_ENV"
205+ rm -f cabal.project cabal.project.local
206+ touch cabal.project
207+ touch cabal.project.local
208+ echo "packages: ${PKGDIR_postgresql_simple}" >> cabal.project
209+ echo "package postgresql-simple" >> cabal.project
210+ echo " ghc-options: -Werror=missing-methods" >> cabal.project
211+ cat >> cabal.project <<EOF
212+ allow-newer: cryptohash-md5-0.11.100.1:base
213+ EOF
214+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(postgresql-simple)$/; }' >> cabal.project.local
215+ cat cabal.project
216+ cat cabal.project.local
217+ - name: dump install plan
218+ run: |
219+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
220+ cabal-plan
221+ - name: restore cache
222+ uses: actions/cache/restore@v3
223+ with:
224+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
225+ path: ~/.cabal/store
226+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
227+ - name: install dependencies
228+ run: |
229+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
230+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
231+ - name: build w/o tests
232+ run: |
233+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
234+ - name: build
235+ run: |
236+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
237+ - name: tests
238+ run: |
239+ $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
240+ - name: cabal check
241+ run: |
242+ cd ${PKGDIR_postgresql_simple} || false
243+ ${CABAL} -vnormal check
244+ - name: haddock
245+ run: |
246+ $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
247+ - name: unconstrained build
248+ run: |
249+ rm -f cabal.project.local
250+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
251+ - name: save cache
252+ uses: actions/cache/save@v3
253+ if: always()
254+ with:
255+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
256+ path: ~/.cabal/store
.github/workflows/simple.ymlnew file+58
@@ -0,0 +1,58 @@
1+name: Simple
2+on:
3+ push:
4+ branches:
5+ - master
6+ pull_request:
7+ branches:
8+ - master
9+
10+jobs:
11+ native:
12+ name: "Simple: GHC ${{ matrix.ghc }} on ${{ matrix.os }}"
13+ runs-on: ${{ matrix.os }}
14+ strategy:
15+ matrix:
16+ os: [macos-latest, windows-latest]
17+ ghc: ['8.10','9.0','9.2','9.4.8','9.6.3','9.8.1']
18+ fail-fast: false
19+ timeout-minutes:
20+ 60
21+ steps:
22+ - name: Set git to use LF
23+ run: |
24+ git config --global core.autocrlf false
25+ git config --global core.eol lf
26+
27+ - name: Set up Haskell
28+ id: setup-haskell
29+ uses: haskell/actions/setup@v2
30+ with:
31+ ghc-version: ${{ matrix.ghc }}
32+ cabal-version: '3.10.2.0'
33+
34+ - name: Set up PostgreSQL
35+ uses: ikalnytskyi/action-setup-postgres@v3
36+ id: postgres
37+ with:
38+ username: ci
39+ password: sw0rdfish
40+ database: test
41+
42+ - name: Checkout
43+ uses: actions/checkout@v3.0.2
44+
45+ - name: Cache
46+ uses: actions/cache@v2.1.3
47+ with:
48+ path: ${{ steps.setup-haskell.outputs.cabal-store }}
49+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ github.sha }}
50+ restore-keys: ${{ runner.os }}-${{ matrix.ghc }}-
51+
52+ - name: Build
53+ run: cabal build all --enable-tests
54+
55+ - name: Test
56+ run: cabal test all --enable-tests --test-show-details=direct
57+ env:
58+ DATABASE_CONNSTRING: ${{ steps.postgres.outputs.connection-uri }}
.gitignore+4−1
@@ -11,4 +11,7 @@ dist/
1111.cabal-sandbox/
1212.stack-work/
1313cabal.sandbox.config
14−/dist-newstyle
14+/dist-newstyle
15+.ghc.environment.*
16+cabal.project.local
17+dump-core
.travis.ymldeleted−76
@@ -1,76 +0,0 @@
1−# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
2−language: c
3−sudo: false
4−
5−cache:
6− directories:
7− - $HOME/.cabsnap
8− - $HOME/.cabal/packages
9−
10−before_cache:
11− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
12− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
13−
14−matrix:
15− include:
16− - env: CABALVER=1.16 GHCVER=7.6.3
17− compiler: ": #GHC 7.6.3"
18− addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}, postgresql: "9.3"}
19− - env: CABALVER=1.18 GHCVER=7.8.4
20− compiler: ": #GHC 7.8.4"
21− addons: { apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}, postgresql: "9.3"}
22− - env: CABALVER=1.22 GHCVER=7.10.2
23− compiler: ": #GHC 7.10.2"
24− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}, postgresql: "9.3"}
25− - env: CABALVER=1.24 GHCVER=8.0.1
26− compiler: ": #GHC 8.0.1"
27− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}, postgresql: "9.3"}
28−
29−before_install:
30− - unset CC
31− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
32− - createdb `whoami` || true
33−
34−install:
35− - cabal --version
36− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
37− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
38− then
39− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
40− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
41− fi
42− - travis_retry cabal update -v
43− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
44− - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
45− - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
46−
47−# check whether current requested install-plan matches cached package-db snapshot
48− - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
49− then
50− echo "cabal build-cache HIT";
51− rm -rfv .ghc;
52− cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
53− cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
54− else
55− echo "cabal build-cache MISS";
56− rm -rf $HOME/.cabsnap;
57− mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
58− cabal install --only-dependencies --enable-tests --enable-benchmarks;
59− fi
60−
61−# snapshot package-db on cache miss
62− - if [ ! -d $HOME/.cabsnap ];
63− then
64− echo "snapshotting package-db to build-cache";
65− mkdir $HOME/.cabsnap;
66− cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
67− cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
68− fi
69−
70−# Here starts the actual work to be performed for the package under test;
71−# any command which exits with a non-zero exit code causes the build to fail.
72−script:
73− - if [ -f configure.ac ]; then autoreconf -i; fi
74− - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging
75− - cabal build # this builds all libraries and executables (including tests/benchmarks)
76− - cabal test
CHANGES.md+160−5
@@ -1,3 +1,158 @@
1+### Version 0.7.0.0 (2023-07-31)
2+
3+ * Remove Eq Null instance. (Future `base` may break it, we remove it profilacticly).
4+ * Use `postgresql-libpq >=0.10.0.0`. It includes critical fixes,
5+ by using `postgresql-simple >=0.7` you won't get older `postgresql-libpq`.
6+ * Drop support for GHC prior 8.6
7+ * Added a class for `postgresql-simple` exceptions: `SomePostgreSqlException`.
8+ This allows to catch all `postgresql-simple` exceptions at once.
9+ (c.f. `AsyncException` in `base).
10+
11+### Version 0.6.5.1 (2023-07-09)
12+
13+ * Support `aeson-2.2.0.0`
14+
15+### Version 0.6.5 (2022-10-30)
16+
17+ * Add `withConnect`
18+
19+### Version 0.6.4 (2021-01-06)
20+
21+ * Add foldCopyData helper function
22+ Thanks to Sebastián Estrella for the implementation
23+ https://github.com/haskellari/postgresql-simple/pull/56
24+ * Implement support for postgresql 'interval' type
25+ Thanks to Andre Marques Lee for the implementation
26+ https://github.com/haskellari/postgresql-simple/pull/60
27+ * Depend on `time-compat` to provide uniform `time` related interface.
28+
29+### Version 0.6.3 (2020-11-15)
30+
31+ * Add `fromFieldJSONByteString`
32+ Thanks to tomjaguarpaw for the implementation
33+ https://github.com/haskellari/postgresql-simple/pull/47
34+ * Add `attoFieldParser`
35+ Thanks to Victor Nawothnig for the implementation
36+ https://github.com/haskellari/postgresql-simple/pull/45
37+ * Add `Identity` and `Const` instance
38+ Thanks to Cary Robbins for the implementation
39+ https://github.com/haskellari/postgresql-simple/pull/46
40+ * Add `withTransactionModeRetry'`, a variant of `withTransactionModeRetry`
41+ for all exception types.
42+ Thanks to Elliot Cameron for the implementation
43+ https://github.com/haskellari/postgresql-simple/pull/42
44+ * Fix spurious aborts when retrying transactions
45+ Thanks to Elliot Cameron for the implementation
46+ https://github.com/haskellari/postgresql-simple/pull/34
47+ * Add `Database.PostgreSQL.Simple.Newtypes` module
48+ with `Aeson` newtype.
49+ https://github.com/haskellari/postgresql-simple/pull/55
50+
51+### Version 0.6.2 (2019-04-26)
52+
53+ * Define `MonadFail Ok`.
54+
55+### Version 0.6.1 (2019-03-04)
56+
57+ * Escape double '??' to a literal '?
58+ Thanks to Felix Paulusma for the implementation.
59+ https://github.com/phadej/postgresql-simple/pull/5
60+
61+ * Mention GHC Generics support in the documentation.
62+ Thanks to Gabriel Gonzalez for the implementation.
63+ https://github.com/phadej/postgresql-simple/pull/6
64+
65+ * Better error message for "Query resulted in a command response
66+ Thanks to Max Amanshauser for the implementation.
67+ https://github.com/phadej/postgresql-simple/pull/7
68+
69+ * fromJSONField: Include JSONPath on JSON parse errors
70+ Thanks to Simon Hengel for the implementation.
71+ https://github.com/phadej/postgresql-simple/pull/2
72+
73+ * No TH in implementation
74+ https://github.com/phadej/postgresql-simple/pull/4
75+
76+### Version 0.6 (2018-10-16)
77+
78+ * *Breaking change*: Use `Only` package's `Only` for a common 1-tuple.
79+
80+ Consider a downstream library depending already both on
81+ `Only` and `postgresql-simple` package. This library my define
82+ a `MyClass` with instances for `Only.Only` and `PostgreSQL.Only`.
83+ As now these types are the same, a library would break.
84+ Therefore I consider "merging" types a breaking change.
85+
86+ There are two ways for adopting this change in that scenario:
87+
88+ - Either CPP-guard `PostgreSQL.Only` instance with
89+
90+ ```haskell
91+ #if !MIN_VERSION_postgresql_simple(0,6,0)
92+ instance MyClass (PostgreSQL.Only a) where ...
93+ #endif
94+ ```
95+
96+ - or simply remove it and add `postgresql-simple >=0.6` lower bound,
97+ making sure that there's only single `Only`.
98+
99+ * Add `ToField` instances for case-insensitive strict and lazy text.
100+ Thanks to Max Tagher for the implementation.
101+ https://github.com/lpsmith/postgresql-simple/pull/232
102+
103+ * Add support to CockroachDB.
104+ Thanks to Georte Steel.
105+ https://github.com/lpsmith/postgresql-simple/pull/245
106+
107+ * Add Generic ConnectInfo instance
108+ Thanks to Dmitry Dzhus.
109+ https://github.com/lpsmith/postgresql-simple/pull/235
110+
111+ * Add `fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)`
112+ https://github.com/lpsmith/postgresql-simple/pull/221
113+
114+ * Add `fromFieldJSONByteString :: FieldParser ByteString`
115+ https://github.com/lpsmith/postgresql-simple/pull/222/files
116+
117+ * Fix off-by-one error in year builder.
118+ Thanks to Nathan Ferris Hunter.
119+ https://github.com/lpsmith/postgresql-simple/pull/230
120+
121+ * Extend ToRow and FromRow to tuples of size 18
122+ Thanks to Bardur Arantsson.
123+ https://github.com/lpsmith/postgresql-simple/pull/229
124+
125+ * Add `Vector` and `Vector.Unboxed` `query` variants.
126+ These are more memory efficient
127+ (especially, if you anyway will convert to some vector)
128+ https://github.com/phadej/1
129+
130+ * Documentation improvements
131+ https://github.com/lpsmith/postgresql-simple/pull/227
132+ https://github.com/lpsmith/postgresql-simple/pull/236
133+
134+### Version 0.5.4.0 (2018-05-23)
135+ * Support GHC-8.4 (Semigroup/Monoid)
136+
137+### Version 0.5.3.0 (2017-05-15)
138+ * Refactored some rudimentary cursor handling code out of the
139+ implementation of the fold operators, into a new
140+ `Database.PostgreSQL.Simple.Cursor` module, thanks to Bardur Arantsson.
141+
142+ * Made the `FromField` instance for `Char` compatible with
143+ postgresql's `bpchar` type. Thanks to Ivan Lazar Miljenovic for
144+ reporting the issue.
145+
146+ * Added `Show` and `Eq` instances for `Notification`, thanks to
147+ Matvey Aksenov.
148+
149+ * Fixed some example code, thanks to Matvey Aksenov.
150+
151+ * Fixed a problem with using `conversionError` to throw exceptions
152+ of type `SomeException`. Previously, the exception would be
153+ wrapped in a second `SomeException` dynamic constructor which
154+ would cause normal GHC typecase idioms over `SomeException` to fail.
155+
1156### Version 0.5.2.1 (2016-06-29)
2157 * Bumped the lower bound for `base` to 4.6. Thanks to Herbert
3158 Valerio Riedel for reporting the issue.
@@ -116,7 +271,7 @@
116271 support UTF8 except for Mule Internal Code, the Multilingual
117272 Extensions for Emacs. An exception should be raised upon
118273 connecting to a database by the backend if the backend cannot
119− accomodate this requirement.
274+ accommodate this requirement.
120275
121276 * Added `Eq` and `Typeable` instances for `Connection`.
122277
@@ -236,7 +391,7 @@
236391 * De-emphasized connect and ConnectInfo in favor of connectPostgreSQL.
237392
238393### Version 0.4.2.2 (2014-05-15)
239− * Fixed compatibility with scientific-0.3.*, thanks to Adam Bergmark
394+ * Fixed compatibility with scientific-0.3.\*, thanks to Adam Bergmark
240395
241396 * Improved documentation of the FromField module, as well as the fold,
242397 foldWithOptions, executeMany, and returning operators.
@@ -254,7 +409,7 @@
254409
255410 * Changed the Identifier and QualifiedIdentifier to use Text in
256411 order to avoid encoding errors. Technically this requires a
257− major verson bump, but let's pretend 0.4.1.0 didn't happen.
412+ major version bump, but let's pretend 0.4.1.0 didn't happen.
258413
259414 * Removed non-exhaustive cases in the ToField instance for Values,
260415 and tweaked error messages.
@@ -414,7 +569,7 @@
414569
415570 * Added a brand new TypeInfo system that gives FromField instances
416571 convenient and efficient access to the pg_type metatable. This
417− replaced the older typename cache, and was neccesary to properly
572+ replaced the older typename cache, and was necessary to properly
418573 support postgres array types. Thanks to Bas van Dijk for his
419574 work on this feature.
420575
@@ -506,7 +661,7 @@
506661 now the preferred way of dealing with `timestamp` (without time zone).
507662
508663 * `Database.PostgreSQL.Simple.Time` is a new module that offers types
509− that accomodate PostgreSQL's infinities.
664+ that accommodate PostgreSQL's infinities.
510665
511666 * All time-related `FromField`/`ToField` instances are now based on new,
512667 higher-speed parsers and printers instead of those provided by the
CONTRIBUTING.mdnew file+13
@@ -0,0 +1,13 @@
1+Patches welcome!
2+
3+- If you are only going to bump bounds:
4+ - If it's really **only bounds**, please simply open an issue (so you'll have a URL to refer to). I have a semi-automated process to make revisions, pull requests only disturb it.
5+ - If patch includes **source code change** (i.e. I'll need to make a release), and it's a patch to support **newer base/GHC version**:
6+ - Amend `tested-with` to include that GHC
7+ - Regenerate `.github/workflows/haskell-ci.yml` with `haskell-ci regenerate` (get the latest from [GitHub haskell-ci/haskell-ci](https://github.com/haskell-ci/haskell-ci))
8+
9+- Don't edit `CHANGELOG.md`, rather include a copyable entry in your pull request description. I often process pull requests in bulk, and everyone editing the `CHANGELOG.md` causes unnecessary conflicts.
10+- For the same reason, do not edit `version` or `x-revision`
11+
12+- I use [`stylish-haskell`](https://github.com/jaspervdj/stylish-haskell) to format imports. I encourage you to use it too, when contributing.
13+- General code style is 4 spaces, just look around how it looks, it's not so strict.
CONTRIBUTORS+1
@@ -33,3 +33,4 @@ Amit Levy <amit@amitlevy.com>
3333Ben Gamari <ben@smart-cactus.org>
3434Edgar Gomes Araujo <talktoedgar@gmail.com>
3535Erik Hesselink <hesselink@gmail.com>
36+Matvey Aksenov <matvey.aksenov@gmail.com>
README.md−3
@@ -1,7 +1,4 @@
1−[![Continuous Integration status][status-png]][status]
21[![Hackage page (downloads and API reference)][hackage-png]][hackage]
32
4− [status-png]: https://api.travis-ci.org/lpsmith/postgresql-simple.svg
5− [status]: http://travis-ci.org/lpsmith/postgresql-simple?branch=master
63 [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg
74 [hackage]: http://hackage.haskell.org/package/postgresql-simple
bench/Select.hsnew file+32
@@ -0,0 +1,32 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Main where
3+
4+import Database.PostgreSQL.Simple
5+import qualified Database.PostgreSQL.Simple.Vector as V
6+import qualified Database.PostgreSQL.Simple.Vector.Unboxed as VU
7+
8+import System.Environment (getArgs)
9+import Data.Foldable (Foldable, foldl')
10+import qualified Data.Vector.Unboxed as VU
11+
12+main :: IO ()
13+main = do
14+ args <- getArgs
15+ conn <- connectPostgreSQL ""
16+ case args of
17+ ("vector":_) -> do
18+ result <- V.query_ conn "SELECT * FROM generate_series(1, 10000000);"
19+ print (process result)
20+ ("unboxed":_) -> do
21+ -- dummy column
22+ result <- VU.query_ conn "SELECT (NULL :: VOID), * FROM generate_series(1, 10000000);"
23+ print (process' result)
24+ _ -> do
25+ result <- query_ conn "SELECT * FROM generate_series(1, 10000000);"
26+ print (process result)
27+
28+process :: Foldable f => f (Only Int) -> Int
29+process = foldl' (\x (Only y) -> max x y) 0
30+
31+process' :: VU.Vector ((), Int) -> Int
32+process' = VU.foldl' (\x (_, y) -> max x y) 0
cabal.haskell-cinew file+5
@@ -0,0 +1,5 @@
1+branches: master
2+postgresql: True
3+
4+-- services aren't supported on Travis on macOS
5+-- osx: 8.4.4
cabal.project+3
@@ -1 +1,4 @@
11packages: .
2+tests: true
3+
4+allow-newer: cryptohash-md5-0.11.100.1:base
cabal.project.local.winnew file+4
@@ -0,0 +1,4 @@
1+constraints: these -assoc
2+
3+package postgresql-libpq
4+ flags: -use-pkg-config
postgresql-simple.cabal+163−119
@@ -1,131 +1,175 @@
1−Name: postgresql-simple
2−Version: 0.5.2.1
3−Synopsis: Mid-Level PostgreSQL client library
4−Description:
5− Mid-Level PostgreSQL client library, forked from mysql-simple.
6−License: BSD3
7−License-file: LICENSE
8−Author: Bryan O'Sullivan, Leon P Smith
9−Maintainer: Leon P Smith <leon@melding-monads.com>
10−Copyright: (c) 2011 MailRank, Inc.
11− (c) 2011-2015 Leon P Smith
12−Category: Database
13−Build-type: Simple
14−
15−Cabal-version: >= 1.9.2
16−
1+cabal-version: 1.12
2+name: postgresql-simple
3+version: 0.7.0.0
4+x-revision: 1
5+synopsis: Mid-Level PostgreSQL client library
6+description:
7+ Mid-Level PostgreSQL client library, forked from mysql-simple.
8+
9+license: BSD3
10+license-file: LICENSE
11+author: Bryan O'Sullivan, Leon P Smith
12+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>
13+copyright:
14+ (c) 2011 MailRank, Inc.
15+ (c) 2011-2018 Leon P Smith
16+ (c) 2018-2020 Oleg Grenrus
17+
18+category: Database
19+build-type: Simple
1720extra-source-files:
18− CONTRIBUTORS
19− CHANGELOG.md
20−
21−Library
22− hs-source-dirs: src
23− Exposed-modules:
24− Database.PostgreSQL.Simple
25− Database.PostgreSQL.Simple.Arrays
26− Database.PostgreSQL.Simple.Copy
27− Database.PostgreSQL.Simple.FromField
28− Database.PostgreSQL.Simple.FromRow
29− Database.PostgreSQL.Simple.LargeObjects
30− Database.PostgreSQL.Simple.HStore
31− Database.PostgreSQL.Simple.HStore.Internal
32− Database.PostgreSQL.Simple.Notification
33− Database.PostgreSQL.Simple.Ok
34− Database.PostgreSQL.Simple.Range
35− Database.PostgreSQL.Simple.SqlQQ
36− Database.PostgreSQL.Simple.Time
37− Database.PostgreSQL.Simple.Time.Internal
38− Database.PostgreSQL.Simple.ToField
39− Database.PostgreSQL.Simple.ToRow
40− Database.PostgreSQL.Simple.Transaction
41− Database.PostgreSQL.Simple.TypeInfo
42− Database.PostgreSQL.Simple.TypeInfo.Macro
43− Database.PostgreSQL.Simple.TypeInfo.Static
44− Database.PostgreSQL.Simple.Types
45− Database.PostgreSQL.Simple.Errors
46−-- Other-modules:
47− Database.PostgreSQL.Simple.Internal
48−
49− Other-modules:
50− Database.PostgreSQL.Simple.Compat
51− Database.PostgreSQL.Simple.HStore.Implementation
52− Database.PostgreSQL.Simple.Time.Implementation
53− Database.PostgreSQL.Simple.Time.Internal.Parser
54− Database.PostgreSQL.Simple.Time.Internal.Printer
55− Database.PostgreSQL.Simple.TypeInfo.Types
56−
57− Build-depends:
58− aeson >= 0.6,
59− attoparsec >= 0.10.3,
60− base >= 4.6 && < 5,
61− bytestring >= 0.9,
62− bytestring-builder,
63− case-insensitive,
64− containers,
65− hashable,
66− postgresql-libpq >= 0.9 && < 0.10,
67− template-haskell,
68− text >= 0.11.1,
69− time,
70− transformers,
71− uuid-types >= 1.0.0,
72− scientific,
73− vector
74−
75− if !impl(ghc >= 7.6)
76− Build-depends:
77− ghc-prim
78−
79− extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns
80− TypeOperators
81−
82− ghc-options: -Wall -fno-warn-name-shadowing
21+ CHANGES.md
22+ CONTRIBUTORS
23+ test/results/malformed-input.expected
24+ test/results/unique-constraint-violation.expected
25+
26+tested-with:
27+ GHC ==8.6.5
28+ || ==8.8.4
29+ || ==8.10.7
30+ || ==9.0.2
31+ || ==9.2.8
32+ || ==9.4.8
33+ || ==9.6.3
34+ || ==9.8.1
35+
36+library
37+ default-language: Haskell2010
38+ hs-source-dirs: src
39+ exposed-modules:
40+ Database.PostgreSQL.Simple
41+ Database.PostgreSQL.Simple.Arrays
42+ Database.PostgreSQL.Simple.Copy
43+ Database.PostgreSQL.Simple.Cursor
44+ Database.PostgreSQL.Simple.Errors
45+ Database.PostgreSQL.Simple.FromField
46+ Database.PostgreSQL.Simple.FromRow
47+ Database.PostgreSQL.Simple.HStore
48+ Database.PostgreSQL.Simple.HStore.Internal
49+ Database.PostgreSQL.Simple.Internal
50+ Database.PostgreSQL.Simple.LargeObjects
51+ Database.PostgreSQL.Simple.Newtypes
52+ Database.PostgreSQL.Simple.Notification
53+ Database.PostgreSQL.Simple.Ok
54+ Database.PostgreSQL.Simple.Range
55+ Database.PostgreSQL.Simple.SqlQQ
56+ Database.PostgreSQL.Simple.Time
57+ Database.PostgreSQL.Simple.Time.Internal
58+ Database.PostgreSQL.Simple.ToField
59+ Database.PostgreSQL.Simple.ToRow
60+ Database.PostgreSQL.Simple.Transaction
61+ Database.PostgreSQL.Simple.TypeInfo
62+ Database.PostgreSQL.Simple.TypeInfo.Macro
63+ Database.PostgreSQL.Simple.TypeInfo.Static
64+ Database.PostgreSQL.Simple.Types
65+ Database.PostgreSQL.Simple.Vector
66+ Database.PostgreSQL.Simple.Vector.Unboxed
67+
68+ -- Other-modules:
69+ other-modules:
70+ Database.PostgreSQL.Simple.Compat
71+ Database.PostgreSQL.Simple.HStore.Implementation
72+ Database.PostgreSQL.Simple.Internal.PQResultUtils
73+ Database.PostgreSQL.Simple.Time.Implementation
74+ Database.PostgreSQL.Simple.Time.Internal.Parser
75+ Database.PostgreSQL.Simple.Time.Internal.Printer
76+ Database.PostgreSQL.Simple.TypeInfo.Types
77+
78+ -- GHC bundled libs
79+ build-depends:
80+ base >=4.12.0.0 && <4.20
81+ , bytestring >=0.10.8.2 && <0.13
82+ , containers >=0.6.0.1 && <0.7
83+ , template-haskell >=2.14.0.0 && <2.22
84+ , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2
85+ , time-compat >=1.9.5 && <1.12
86+ , transformers >=0.5.6.2 && <0.7
87+
88+ -- Other dependencies
89+ build-depends:
90+ aeson >=2.1.2.1 && <2.3
91+ , attoparsec >=0.14.4 && <0.15
92+ , case-insensitive >=1.2.1.0 && <1.3
93+ , hashable >=1.4.3.0 && <1.5
94+ , Only >=0.1 && <0.1.1
95+ , postgresql-libpq >=0.10.0.0 && <0.11
96+ , scientific >=0.3.7.0 && <0.4
97+ , uuid-types >=1.0.5 && <1.1
98+ , vector >=0.13.0.0 && <0.14
99+
100+ default-extensions:
101+ BangPatterns
102+ DoAndIfThenElse
103+ OverloadedStrings
104+ TypeOperators
105+ ViewPatterns
106+
107+ ghc-options: -Wall -fno-warn-name-shadowing
83108
84109source-repository head
85110 type: git
86− location: http://github.com/lpsmith/postgresql-simple
87−
88−source-repository this
89− type: git
90− location: http://github.com/lpsmith/postgresql-simple
91− tag: v0.5.2.1
111+ location: http://github.com/haskellari/postgresql-simple
112+
113+test-suite inspection
114+ default-language: Haskell2010
115+ type: exitcode-stdio-1.0
116+ hs-source-dirs: test
117+ main-is: Inspection.hs
118+ build-depends:
119+ base
120+ , inspection-testing >=0.4.1.1 && <0.6
121+ , postgresql-libpq
122+ , postgresql-simple
123+ , tasty
124+ , tasty-hunit
92125
93126test-suite test
94− type: exitcode-stdio-1.0
95−
96− hs-source-dirs: test
97− main-is: Main.hs
127+ default-language: Haskell2010
128+ type: exitcode-stdio-1.0
129+ hs-source-dirs: test
130+ main-is: Main.hs
98131 other-modules:
99132 Common
133+ Exception
134+ Interval
100135 Notify
101136 Serializable
102137 Time
103138
104− ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
105−
106− extensions: NamedFieldPuns
107− , OverloadedStrings
108− , Rank2Types
109− , RecordWildCards
110− , PatternGuards
111− , ScopedTypeVariables
112−
113− build-depends: base
114− , aeson
115− , base16-bytestring
116− , bytestring
117− , containers
118− , cryptohash
119− , filepath
120− , tasty
121− , tasty-hunit
122− , tasty-golden
123− , HUnit
124− , postgresql-simple
125− , text
126− , time
127− , vector
128−
129− if !impl(ghc >= 7.6)
130− build-depends:
131− ghc-prim
139+ ghc-options: -threaded
140+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind
141+ default-extensions:
142+ NamedFieldPuns
143+ OverloadedStrings
144+ PatternGuards
145+ Rank2Types
146+ RecordWildCards
147+ ScopedTypeVariables
148+
149+ build-depends:
150+ aeson
151+ , base
152+ , base16-bytestring
153+ , bytestring
154+ , case-insensitive
155+ , containers
156+ , cryptohash-md5 >=0.11.100.1 && <0.12
157+ , filepath
158+ , HUnit
159+ , postgresql-simple
160+ , tasty
161+ , tasty-golden
162+ , tasty-hunit
163+ , text
164+ , time-compat
165+ , vector
166+
167+benchmark select
168+ default-language: Haskell2010
169+ type: exitcode-stdio-1.0
170+ hs-source-dirs: bench
171+ main-is: Select.hs
172+ build-depends:
173+ base
174+ , postgresql-simple
175+ , vector
src/Database/PostgreSQL/Simple.hs+36−119
@@ -64,6 +64,7 @@ module Database.PostgreSQL.Simple
6464 , Only(..)
6565 , (:.)(..)
6666 -- ** Exceptions
67+ , SomePostgreSqlException(..)
6768 , SqlError(..)
6869 , PQ.ExecStatus(..)
6970 , FormatError(..)
@@ -73,6 +74,7 @@ module Database.PostgreSQL.Simple
7374 , Base.connectPostgreSQL
7475 , Base.close
7576 , Base.connect
77+ , Base.withConnect
7678 , Base.ConnectInfo(..)
7779 , Base.defaultConnectInfo
7880 , Base.postgreSQLConnectionString
@@ -118,30 +120,26 @@ module Database.PostgreSQL.Simple
118120 , formatQuery
119121 ) where
120122
121−import Data.ByteString.Builder
122− ( Builder, byteString, char8, intDec )
123+import Data.ByteString.Builder (Builder, byteString, char8)
123124import Control.Applicative ((<$>))
124125import Control.Exception as E
125−import Control.Monad (unless)
126126import Data.ByteString (ByteString)
127127import Data.Int (Int64)
128128import Data.List (intersperse)
129129import Data.Monoid (mconcat)
130−import Database.PostgreSQL.Simple.Compat ( (<>), toByteString )
130+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
131+import Database.PostgreSQL.Simple.Cursor
131132import Database.PostgreSQL.Simple.FromField (ResultError(..))
132133import Database.PostgreSQL.Simple.FromRow (FromRow(..))
133−import Database.PostgreSQL.Simple.Ok
134134import Database.PostgreSQL.Simple.ToField (Action(..))
135135import Database.PostgreSQL.Simple.ToRow (ToRow(..))
136136import Database.PostgreSQL.Simple.Types
137137 ( Binary(..), In(..), Only(..), Query(..), (:.)(..) )
138138import Database.PostgreSQL.Simple.Internal as Base
139+import Database.PostgreSQL.Simple.Internal.PQResultUtils
139140import Database.PostgreSQL.Simple.Transaction
140−import Database.PostgreSQL.Simple.TypeInfo
141141import qualified Database.PostgreSQL.LibPQ as PQ
142142import qualified Data.ByteString.Char8 as B
143−import Control.Monad.Trans.Reader
144−import Control.Monad.Trans.State.Strict
145143
146144
147145-- | Format a query string.
@@ -280,21 +278,31 @@ parseTemplate template =
280278 skipSpace = B.dropWhile isSpace_ascii
281279
282280
283−
284281buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
285282buildQuery conn q template xs =
286283 zipParams (split template) <$> mapM (buildAction conn q xs) xs
287284 where split s =
288− let (h,t) = B.break (=='?') s
285+ -- This part escapes double '??'s to make literal '?'s possible
286+ -- in PostgreSQL queries using the JSON operators: @?@, @?|@ and @?&@
287+ let (h,t) = breakOnSingleQuestionMark s
289288 in byteString h
290289 : if B.null t
291290 then []
292291 else split (B.tail t)
293292 zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps
294293 zipParams [t] [] = t
295− zipParams _ _ = fmtError (show (B.count '?' template) ++
296− " '?' characters, but " ++
294+ zipParams _ _ = fmtError (show countSingleQs ++
295+ " single '?' characters, but " ++
297296 show (length xs) ++ " parameters") q xs
297+ countSingleQs = go 0 template
298+ where go i "" = (i :: Int)
299+ go i bs = case qms of
300+ ("?","?") -> go i nextQMBS
301+ ("?",_) -> go (i+1) nextQMBS
302+ _ -> i
303+ where qms = B.splitAt 1 qmBS
304+ (qmBS,nextQMBS) = B.splitAt 2 qmBS'
305+ qmBS' = B.dropWhile (/= '?') bs
298306
299307-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not
300308-- expected to return results.
@@ -332,7 +340,7 @@ execute conn template qs = do
332340-- @
333341-- executeMany c [sql|
334342-- UPDATE sometable
335−-- SET sometable.y = upd.y
343+-- SET y = upd.y
336344-- FROM (VALUES (?,?)) as upd(x,y)
337345-- WHERE sometable.x = upd.x
338346-- |] [(1, \"hello\"),(2, \"world\")]
@@ -359,6 +367,7 @@ executeMany conn q qs = do
359367returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r]
360368returning = returningWith fromRow
361369
370+-- | A version of 'returning' taking parser as argument
362371returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r]
363372returningWith _ _ _ [] = return []
364373returningWith parser conn q qs = do
@@ -524,7 +533,7 @@ foldWithOptions_ :: (FromRow r) =>
524533 -> a -- ^ Initial state for result consumer.
525534 -> (a -> r -> IO a) -- ^ Result consumer.
526535 -> IO a
527−foldWithOptions_ opts conn query a f = doFold opts fromRow conn query query a f
536+foldWithOptions_ opts conn query' a f = doFold opts fromRow conn query' query' a f
528537
529538-- | A version of 'foldWithOptions_' taking a parser as an argument
530539foldWithOptionsAndParser_ :: FoldOptions
@@ -534,7 +543,7 @@ foldWithOptionsAndParser_ :: FoldOptions
534543 -> a -- ^ Initial state for result consumer.
535544 -> (a -> r -> IO a) -- ^ Result consumer.
536545 -> IO a
537−foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f
546+foldWithOptionsAndParser_ opts parser conn query' a f = doFold opts parser conn query' query' a f
538547
539548doFold :: FoldOptions
540549 -> RowParser row
@@ -562,39 +571,17 @@ doFold FoldOptions{..} parser conn _template q a0 f = do
562571 PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown"
563572 -- Not sure what this means.
564573 where
565− declare = do
566− name <- newTempName conn
567− _ <- execute_ conn $ mconcat
568− [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ]
569− return name
570− close name =
571− (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex ->
572− -- Don't throw exception if CLOSE failed because the transaction is
573− -- aborted. Otherwise, it will throw away the original error.
574− unless (isFailedTransactionError ex) $ throwIO ex
575−
576− go = bracket declare close $ \(Query name) ->
577− let q = toByteString (byteString "FETCH FORWARD "
578− <> intDec chunkSize
579− <> byteString " FROM "
580− <> byteString name
581− )
582− loop a = do
583− result <- exec conn q
584− status <- PQ.resultStatus result
585− case status of
586− PQ.TuplesOk -> do
587− nrows <- PQ.ntuples result
588− ncols <- PQ.nfields result
589− if nrows > 0
590− then do
591− let inner a row = do
592− x <- getRowWith parser row ncols conn result
593− f a x
594− foldM' inner a 0 (nrows - 1) >>= loop
595− else return a
596− _ -> throwResultError "fold" result status
597− in loop a0
574+ declare =
575+ declareCursor conn q
576+ fetch cursor a =
577+ foldForwardWithParser cursor parser chunkSize f a
578+
579+ go = bracket declare closeCursor $ \cursor ->
580+ let loop a = fetch cursor a >>=
581+ \r -> case r of
582+ Left x -> return x
583+ Right x -> loop x
584+ in loop a0
598585
599586-- FIXME: choose the Automatic chunkSize more intelligently
600587-- One possibility is to use the type of the results, although this
@@ -644,76 +631,6 @@ forEachWith_ :: RowParser r
644631forEachWith_ parser conn template = foldWith_ parser conn template () . const
645632{-# INLINE forEachWith_ #-}
646633
647−forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
648−forM' lo hi m = loop hi []
649− where
650− loop !n !as
651− | n < lo = return as
652− | otherwise = do
653− a <- m n
654− loop (n-1) (a:as)
655−{-# INLINE forM' #-}
656−
657−foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a
658−foldM' f a lo hi = loop a lo
659− where
660− loop a !n
661− | n > hi = return a
662− | otherwise = do
663− a' <- f a n
664− loop a' (n+1)
665−{-# INLINE foldM' #-}
666−
667−finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
668−finishQueryWith parser conn q result = do
669− status <- PQ.resultStatus result
670− case status of
671− PQ.EmptyQuery ->
672− throwIO $ QueryError "query: Empty query" q
673− PQ.CommandOk ->
674− throwIO $ QueryError "query resulted in a command response" q
675− PQ.TuplesOk -> do
676− nrows <- PQ.ntuples result
677− ncols <- PQ.nfields result
678− forM' 0 (nrows-1) $ \row ->
679− getRowWith parser row ncols conn result
680− PQ.CopyOut ->
681− throwIO $ QueryError "query: COPY TO is not supported" q
682− PQ.CopyIn ->
683− throwIO $ QueryError "query: COPY FROM is not supported" q
684− PQ.BadResponse -> throwResultError "query" result status
685− PQ.NonfatalError -> throwResultError "query" result status
686− PQ.FatalError -> throwResultError "query" result status
687−
688−getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r
689−getRowWith parser row ncols conn result = do
690− let rw = Row row result
691− let unCol (PQ.Col x) = fromIntegral x :: Int
692− okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
693− case okvc of
694− Ok (val,col) | col == ncols -> return val
695− | otherwise -> do
696− vals <- forM' 0 (ncols-1) $ \c -> do
697− tinfo <- getTypeInfo conn =<< PQ.ftype result c
698− v <- PQ.getvalue result row c
699− return ( tinfo
700− , fmap ellipsis v )
701− throw (ConversionFailed
702− (show (unCol ncols) ++ " values: " ++ show vals)
703− Nothing
704− ""
705− (show (unCol col) ++ " slots in target type")
706− "mismatch between number of columns to \
707− \convert and number in target type")
708− Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
709− Errors [x] -> throwIO x
710− Errors xs -> throwIO $ ManyErrors xs
711−
712−ellipsis :: ByteString -> ByteString
713−ellipsis bs
714− | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
715− | otherwise = bs
716−
717634
718635-- $use
719636--
@@ -985,7 +902,7 @@ ellipsis bs
985902-- all values of the given PostgreSQL type is considered \"compatible\".
986903-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@
987904-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately
988−-- represent a @SMALLINT@, so it is considered compatble with those types.
905+-- represent a @SMALLINT@, so it is considered compatible with those types.
989906--
990907-- * A numeric compatibility check is based only on the type of a
991908-- column, /not/ on its values. For instance, a PostgreSQL 64-bit
src/Database/PostgreSQL/Simple/Arrays.hs+2−2
@@ -42,9 +42,9 @@ array delim = char '{' *> option [] (arrays <|> strings) <* char '}'
4242quoted :: Parser ByteString
4343quoted = char '"' *> option "" contents <* char '"'
4444 where
45− esc = char '\\' *> (char '\\' <|> char '"')
45+ esc' = char '\\' *> (char '\\' <|> char '"')
4646 unQ = takeWhile1 (notInClass "\"\\")
47− contents = mconcat <$> many (unQ <|> B.singleton <$> esc)
47+ contents = mconcat <$> many (unQ <|> B.singleton <$> esc')
4848
4949-- | Recognizes a plain string literal, not containing quotes or brackets and
5050-- not containing the delimiter character.
src/Database/PostgreSQL/Simple/Compat.hs−53
@@ -12,36 +12,13 @@ module Database.PostgreSQL.Simple.Compat
1212 ) where
1313
1414import qualified Control.Exception as E
15−import Data.Monoid
1615import Data.ByteString (ByteString)
17−#if MIN_VERSION_bytestring(0,10,0)
1816import Data.ByteString.Lazy (toStrict)
19−#else
20−import qualified Data.ByteString as B
21−import Data.ByteString.Lazy (toChunks)
22−#endif
2317import Data.ByteString.Builder (Builder, toLazyByteString)
24−
25−#if MIN_VERSION_scientific(0,3,0)
2618import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
27−#else
28−import Data.Scientific (scientificBuilder)
29−#endif
30−
31−#if __GLASGOW_HASKELL__ >= 702
3219import System.IO.Unsafe (unsafeDupablePerformIO)
33−#elif __GLASGOW_HASKELL__ >= 611
34−import GHC.IO (unsafeDupablePerformIO)
35−#else
36−import GHC.IOBase (unsafeDupablePerformIO)
37−#endif
38−
3920import Data.Fixed (Pico)
40−#if MIN_VERSION_base(4,7,0)
4121import Data.Fixed (Fixed(MkFixed))
42−#else
43−import Unsafe.Coerce (unsafeCoerce)
44−#endif
4522
4623-- | Like 'E.mask', but backported to base before version 4.3.0.
4724--
@@ -51,44 +28,14 @@ import Unsafe.Coerce (unsafeCoerce)
5128-- 'withTransactionMode' function calls the restore callback only once, so we
5229-- don't need that polymorphism.
5330mask :: ((IO a -> IO a) -> IO b) -> IO b
54−#if MIN_VERSION_base(4,3,0)
5531mask io = E.mask $ \restore -> io restore
56−#else
57−mask io = do
58− b <- E.blocked
59− E.block $ io $ \m -> if b then m else E.unblock m
60−#endif
6132{-# INLINE mask #-}
6233
63−#if !MIN_VERSION_base(4,5,0)
64−infixr 6 <>
65−
66−(<>) :: Monoid m => m -> m -> m
67−(<>) = mappend
68−{-# INLINE (<>) #-}
69−#endif
70−
7134toByteString :: Builder -> ByteString
72−#if MIN_VERSION_bytestring(0,10,0)
7335toByteString x = toStrict (toLazyByteString x)
74−#else
75−toByteString x = B.concat (toChunks (toLazyByteString x))
76−#endif
77−
78−#if MIN_VERSION_base(4,7,0)
7936
8037toPico :: Integer -> Pico
8138toPico = MkFixed
8239
8340fromPico :: Pico -> Integer
8441fromPico (MkFixed i) = i
85−
86−#else
87−
88−toPico :: Integer -> Pico
89−toPico = unsafeCoerce
90−
91−fromPico :: Pico -> Integer
92−fromPico = unsafeCoerce
93−
94−#endif
src/Database/PostgreSQL/Simple/Copy.hs+32−4
@@ -32,6 +32,7 @@ module Database.PostgreSQL.Simple.Copy
3232 ( copy
3333 , copy_
3434 , CopyOutResult(..)
35+ , foldCopyData
3536 , getCopyData
3637 , putCopyData
3738 , putCopyEnd
@@ -48,13 +49,13 @@ import qualified Data.ByteString.Char8 as B
4849import qualified Database.PostgreSQL.LibPQ as PQ
4950import Database.PostgreSQL.Simple
5051import Database.PostgreSQL.Simple.Types
51−import Database.PostgreSQL.Simple.Internal
52+import Database.PostgreSQL.Simple.Internal hiding (result, row)
5253
5354
5455-- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former
5556-- case, the connection's state will change to @CopyIn@; in the latter,
5657-- @CopyOut@. The connection must be in the ready state in order
57−-- to call this function. Performs parameter subsitution.
58+-- to call this function. Performs parameter substitution.
5859
5960copy :: ( ToRow params ) => Connection -> Query -> params -> IO ()
6061copy conn template qs = do
@@ -75,15 +76,18 @@ doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO ()
7576doCopy funcName conn template q = do
7677 result <- exec conn q
7778 status <- PQ.resultStatus result
78− let err = throwIO $ QueryError
79− (B.unpack funcName ++ " " ++ show status)
79+ let errMsg msg = throwIO $ QueryError
80+ (B.unpack funcName ++ " " ++ msg)
8081 template
82+ let err = errMsg $ show status
8183 case status of
8284 PQ.EmptyQuery -> err
8385 PQ.CommandOk -> err
8486 PQ.TuplesOk -> err
8587 PQ.CopyOut -> return ()
8688 PQ.CopyIn -> return ()
89+ PQ.CopyBoth -> errMsg "COPY BOTH is not supported"
90+ PQ.SingleTuple -> errMsg "single-row mode is not supported"
8791 PQ.BadResponse -> throwResultError funcName result status
8892 PQ.NonfatalError -> throwResultError funcName result status
8993 PQ.FatalError -> throwResultError funcName result status
@@ -97,6 +101,30 @@ data CopyOutResult
97101 deriving (Eq, Typeable, Show)
98102
99103
104+-- | Fold over @COPY TO STDOUT@ query passing each copied row to an accumulator
105+-- and calling a post-process at the end. A connection must be in the
106+-- @CopyOut@ state in order to call this function.
107+--
108+-- __Example__
109+--
110+-- > (acc, count) <- foldCopyData conn
111+-- > (\acc row -> return (row:acc))
112+-- > (\acc count -> return (acc, count))
113+-- > []
114+
115+foldCopyData
116+ :: Connection -- ^ Database connection
117+ -> (a -> B.ByteString -> IO a) -- ^ Accumulate one row of the result
118+ -> (a -> Int64 -> IO b) -- ^ Post-process accumulator with a count of rows
119+ -> a -- ^ Initial accumulator
120+ -> IO b -- ^ Result
121+foldCopyData conn f g !acc = do
122+ result <- getCopyData conn
123+ case result of
124+ CopyOutRow row -> f acc row >>= foldCopyData conn f g
125+ CopyOutDone count -> g acc count
126+
127+
100128-- | Retrieve some data from a @COPY TO STDOUT@ query. A connection
101129-- must be in the @CopyOut@ state in order to call this function. If this
102130-- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state,
src/Database/PostgreSQL/Simple/Cursor.hsnew file+98
@@ -0,0 +1,98 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.Cursor
6+-- Copyright: (c) 2011-2012 Leon P Smith
7+-- (c) 2017 Bardur Arantsson
8+-- License: BSD3
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+--
11+------------------------------------------------------------------------------
12+
13+module Database.PostgreSQL.Simple.Cursor
14+ (
15+ -- * Types
16+ Cursor
17+ -- * Cursor management
18+ , declareCursor
19+ , closeCursor
20+ -- * Folding over rows from a cursor
21+ , foldForward
22+ , foldForwardWithParser
23+ ) where
24+
25+import Data.ByteString.Builder (intDec)
26+import Control.Applicative ((<$>))
27+import Control.Exception as E
28+import Control.Monad (unless, void)
29+import Data.Monoid (mconcat)
30+import Database.PostgreSQL.Simple.Compat ((<>), toByteString)
31+import Database.PostgreSQL.Simple.FromRow (FromRow(..))
32+import Database.PostgreSQL.Simple.Types (Query(..))
33+import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)
34+import Database.PostgreSQL.Simple.Internal.PQResultUtils
35+import Database.PostgreSQL.Simple.Transaction
36+import qualified Database.PostgreSQL.LibPQ as PQ
37+
38+-- | Cursor within a transaction.
39+data Cursor = Cursor !Query !Connection
40+
41+-- | Declare a temporary cursor. The cursor is given a
42+-- unique name for the given connection.
43+declareCursor :: Connection -> Query -> IO Cursor
44+declareCursor conn q = do
45+ name <- newTempName conn
46+ void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q]
47+ return $ Cursor name conn
48+
49+-- | Close the given cursor.
50+closeCursor :: Cursor -> IO ()
51+closeCursor (Cursor name conn) =
52+ (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex ->
53+ -- Don't throw exception if CLOSE failed because the transaction is
54+ -- aborted. Otherwise, it will throw away the original error.
55+ unless (isFailedTransactionError ex) $ throwIO ex
56+
57+-- | Fold over a chunk of rows from the given cursor, calling the
58+-- supplied fold-like function on each row as it is received. In case
59+-- the cursor is exhausted, a 'Left' value is returned, otherwise a
60+-- 'Right' value is returned.
61+foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
62+foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do
63+ let q = "FETCH FORWARD "
64+ <> (toByteString $ intDec chunkSize)
65+ <> " FROM "
66+ <> fromQuery name
67+ result <- exec conn q
68+ status <- PQ.resultStatus result
69+ case status of
70+ PQ.TuplesOk -> do
71+ nrows <- PQ.ntuples result
72+ ncols <- PQ.nfields result
73+ if nrows > 0
74+ then do
75+ let inner a row = do
76+ x <- getRowWith parser row ncols conn result
77+ f a x
78+ Right <$> foldM' inner a0 0 (nrows - 1)
79+ else
80+ return $ Left a0
81+ _ -> throwResultError "foldForwardWithParser" result status
82+
83+-- | Fold over a chunk of rows, calling the supplied fold-like function
84+-- on each row as it is received. In case the cursor is exhausted,
85+-- a 'Left' value is returned, otherwise a 'Right' value is returned.
86+foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a)
87+foldForward cursor = foldForwardWithParser cursor fromRow
88+
89+
90+foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a
91+foldM' f a lo hi = loop a lo
92+ where
93+ loop x !n
94+ | n > hi = return x
95+ | otherwise = do
96+ x' <- f x n
97+ loop x' (n+1)
98+{-# INLINE foldM' #-}
src/Database/PostgreSQL/Simple/Errors.hs+4−3
@@ -25,7 +25,6 @@ module Database.PostgreSQL.Simple.Errors
2525 )
2626 where
2727
28−import Control.Applicative
2928import Control.Exception as E
3029
3130import Data.Attoparsec.ByteString.Char8
@@ -60,11 +59,13 @@ data ConstraintViolation
6059 deriving (Show, Eq, Ord, Typeable)
6160
6261-- Default instance should be enough
63−instance Exception ConstraintViolation
62+instance Exception ConstraintViolation where
63+ toException = postgresqlExceptionToException
64+ fromException = postgresqlExceptionFromException
6465
6566
6667-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and
67−-- succeedes only if able to parse sqlErrorMsg.
68+-- succeeds only if able to parse sqlErrorMsg.
6869--
6970-- > createUser = handleJust constraintViolation handler $ execute conn ...
7071-- > where
src/Database/PostgreSQL/Simple/FromField.hs+124−70
@@ -1,7 +1,8 @@
11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
33{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}
4−{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
4+{-# LANGUAGE RecordWildCards #-}
5+{-# LANGUAGE PolyKinds #-}
56
67{- |
78Module: Database.PostgreSQL.Simple.FromField
@@ -106,25 +107,27 @@ module Database.PostgreSQL.Simple.FromField
106107 , PQ.Oid(..)
107108 , PQ.Format(..)
108109 , pgArrayFieldParser
110+ , attoFieldParser
109111
110112 , optionalField
111113 , fromJSONField
114+ , fromFieldJSONByteString
112115 ) where
113116
114117#include "MachDeps.h"
115118
116−import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) )
119+import Control.Applicative ( Const(Const), (<|>), (<$>), pure, (*>), (<*) )
117120import Control.Concurrent.MVar (MVar, newMVar)
118−import Control.Exception (Exception)
121+import Control.Exception (Exception (toException, fromException))
119122import qualified Data.Aeson as JSON
120−import qualified Data.Aeson.Parser as JSON (value')
121123import Data.Attoparsec.ByteString.Char8 hiding (Result)
122124import Data.ByteString (ByteString)
123125import qualified Data.ByteString.Char8 as B
126+import Data.Functor.Identity (Identity(Identity))
124127import Data.Int (Int16, Int32, Int64)
125128import Data.IORef (IORef, newIORef)
126129import Data.Ratio (Ratio)
127−import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay )
130+import Data.Time.Compat ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay, CalendarDiffTime )
128131import Data.Typeable (Typeable, typeOf)
129132import Data.Vector (Vector)
130133import Data.Vector.Mutable (IOVector)
@@ -135,7 +138,6 @@ import Database.PostgreSQL.Simple.Ok
135138import Database.PostgreSQL.Simple.Types
136139import Database.PostgreSQL.Simple.TypeInfo as TI
137140import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
138−import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
139141import Database.PostgreSQL.Simple.Time
140142import Database.PostgreSQL.Simple.Arrays as Arrays
141143import qualified Database.PostgreSQL.LibPQ as PQ
@@ -152,6 +154,8 @@ import qualified Data.UUID.Types as UUID
152154import Data.Scientific (Scientific)
153155import GHC.Real (infinity, notANumber)
154156
157+import qualified Data.Aeson.Types as JSON
158+
155159-- | Exception thrown if conversion from a SQL value to a Haskell
156160-- value fails.
157161data ResultError = Incompatible { errSQLType :: String
@@ -178,7 +182,9 @@ data ResultError = Incompatible { errSQLType :: String
178182 -- between metadata and actual data in a row).
179183 deriving (Eq, Show, Typeable)
180184
181−instance Exception ResultError
185+instance Exception ResultError where
186+ toException = postgresqlExceptionToException
187+ fromException = postgresqlExceptionFromException
182188
183189left :: Exception a => a -> Conversion b
184190left = conversionError
@@ -244,9 +250,11 @@ tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column
244250 then Nothing
245251 else Just x
246252
247−-- | If the column has a table associated with it, this returns the number
248−-- off the associated table column. Numbering starts from 0. Analogous
249−-- to libpq's @PQftablecol@.
253+-- | If the column has a table associated with it, this returns the
254+-- number of the associated table column. Table columns have
255+-- nonzero numbers. Zero is returned if the specified column is not
256+-- a simple reference to a table column, or when using pre-3.0
257+-- protocol. Analogous to libpq's @PQftablecol@.
250258
251259tableColumn :: Field -> Int
252260tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column))
@@ -262,9 +270,15 @@ format Field{..} = unsafeDupablePerformIO (PQ.fformat result column)
262270-- | void
263271instance FromField () where
264272 fromField f _bs
265− | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f ""
273+ | typeOid f /= TI.voidOid = returnError Incompatible f ""
266274 | otherwise = pure ()
267275
276+instance (FromField a) => FromField (Const a b) where
277+ fromField f bs = Const <$> fromField f bs
278+
279+instance (FromField a) => FromField (Identity a) where
280+ fromField f bs = Identity <$> fromField f bs
281+
268282-- | For dealing with null values. Compatible with any postgresql type
269283-- compatible with type @a@. Note that the type is not checked if
270284-- the value is null, although it is inadvisable to rely on this
@@ -292,7 +306,7 @@ instance FromField Null where
292306-- | bool
293307instance FromField Bool where
294308 fromField f bs
295− | typeOid f /= $(inlineTypoid TI.bool) = returnError Incompatible f ""
309+ | typeOid f /= TI.boolOid = returnError Incompatible f ""
296310 | bs == Nothing = returnError UnexpectedNull f ""
297311 | bs == Just "t" = pure True
298312 | bs == Just "f" = pure False
@@ -300,9 +314,9 @@ instance FromField Bool where
300314
301315-- | \"char\", bpchar
302316instance FromField Char where
303− fromField f bs =
304− if $(mkCompats [TI.char,TI.bpchar]) (typeOid f)
305− then case bs of
317+ fromField f bs0 =
318+ if (eq TI.charOid \/ eq TI.bpcharOid) (typeOid f)
319+ then case bs0 of
306320 Nothing -> returnError UnexpectedNull f ""
307321 Just bs -> if B.length bs /= 1
308322 then returnError ConversionFailed f "length not 1"
@@ -311,11 +325,11 @@ instance FromField Char where
311325
312326-- | int2
313327instance FromField Int16 where
314− fromField = atto ok16 $ signed decimal
328+ fromField = attoFieldParser ok16 $ signed decimal
315329
316330-- | int2, int4
317331instance FromField Int32 where
318− fromField = atto ok32 $ signed decimal
332+ fromField = attoFieldParser ok32 $ signed decimal
319333
320334#if WORD_SIZE_IN_BITS < 64
321335-- | int2, int4, and if compiled as 64-bit code, int8 as well.
@@ -325,37 +339,37 @@ instance FromField Int32 where
325339-- This library was compiled as 64-bit code.
326340#endif
327341instance FromField Int where
328− fromField = atto okInt $ signed decimal
342+ fromField = attoFieldParser okInt $ signed decimal
329343
330344-- | int2, int4, int8
331345instance FromField Int64 where
332− fromField = atto ok64 $ signed decimal
346+ fromField = attoFieldParser ok64 $ signed decimal
333347
334348-- | int2, int4, int8
335349instance FromField Integer where
336− fromField = atto ok64 $ signed decimal
350+ fromField = attoFieldParser ok64 $ signed decimal
337351
338352-- | int2, float4 (Uses attoparsec's 'double' routine, for
339353-- better accuracy convert to 'Scientific' or 'Rational' first)
340354instance FromField Float where
341− fromField = atto ok (realToFrac <$> pg_double)
342− where ok = $(mkCompats [TI.float4,TI.int2])
355+ fromField = attoFieldParser ok (realToFrac <$> pg_double)
356+ where ok = eq TI.float4Oid \/ eq TI.int2Oid
343357
344358-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for
345359-- better accuracy convert to 'Scientific' or 'Rational' first)
346360instance FromField Double where
347− fromField = atto ok pg_double
348− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4])
361+ fromField = attoFieldParser ok pg_double
362+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid
349363
350364-- | int2, int4, int8, float4, float8, numeric
351365instance FromField (Ratio Integer) where
352− fromField = atto ok pg_rational
353− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])
366+ fromField = attoFieldParser ok pg_rational
367+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
354368
355369-- | int2, int4, int8, float4, float8, numeric
356370instance FromField Scientific where
357− fromField = atto ok rational
358− where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric])
371+ fromField = attoFieldParser ok rational
372+ where ok = eq TI.float4Oid \/ eq TI.float8Oid \/ eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid \/ eq TI.numericOid
359373
360374unBinary :: Binary t -> t
361375unBinary (Binary x) = x
@@ -376,13 +390,13 @@ pg_rational
376390
377391-- | bytea, name, text, \"char\", bpchar, varchar, unknown
378392instance FromField SB.ByteString where
379− fromField f dat = if typeOid f == $(inlineTypoid TI.bytea)
393+ fromField f dat = if typeOid f == TI.byteaOid
380394 then unBinary <$> fromField f dat
381395 else doFromField f okText' pure dat
382396
383397-- | oid
384398instance FromField PQ.Oid where
385− fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.oid)) decimal f dat
399+ fromField f dat = PQ.Oid <$> attoFieldParser (== TI.oidOid) decimal f dat
386400
387401-- | bytea, name, text, \"char\", bpchar, varchar, unknown
388402instance FromField LB.ByteString where
@@ -390,7 +404,7 @@ instance FromField LB.ByteString where
390404
391405unescapeBytea :: Field -> SB.ByteString
392406 -> Conversion (Binary SB.ByteString)
393−unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of
407+unescapeBytea f str' = case unsafeDupablePerformIO (PQ.unescapeBytea str') of
394408 Nothing -> returnError ConversionFailed f "unescapeBytea failed"
395409 Just str -> pure (Binary str)
396410
@@ -441,48 +455,57 @@ instance FromField [Char] where
441455
442456-- | timestamptz
443457instance FromField UTCTime where
444− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime
458+ fromField = ff TI.timestamptzOid "UTCTime" parseUTCTime
445459
446460-- | timestamptz
447461instance FromField ZonedTime where
448− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime
462+ fromField = ff TI.timestamptzOid "ZonedTime" parseZonedTime
449463
450464-- | timestamp
451465instance FromField LocalTime where
452− fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime
466+ fromField = ff TI.timestampOid "LocalTime" parseLocalTime
453467
454468-- | date
455469instance FromField Day where
456− fromField = ff $(inlineTypoid TI.date) "Day" parseDay
470+ fromField = ff TI.dateOid "Day" parseDay
457471
458472-- | time
459473instance FromField TimeOfDay where
460− fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay
474+ fromField = ff TI.timeOid "TimeOfDay" parseTimeOfDay
461475
462476-- | timestamptz
463477instance FromField UTCTimestamp where
464− fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp
478+ fromField = ff TI.timestamptzOid "UTCTimestamp" parseUTCTimestamp
465479
466480-- | timestamptz
467481instance FromField ZonedTimestamp where
468− fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp
482+ fromField = ff TI.timestamptzOid "ZonedTimestamp" parseZonedTimestamp
469483
470484-- | timestamp
471485instance FromField LocalTimestamp where
472− fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp
486+ fromField = ff TI.timestampOid "LocalTimestamp" parseLocalTimestamp
473487
474488-- | date
475489instance FromField Date where
476− fromField = ff $(inlineTypoid TI.date) "Date" parseDate
490+ fromField = ff TI.dateOid "Date" parseDate
491+
492+-- | interval. Requires you to configure intervalstyle as @iso_8601@.
493+--
494+-- You can configure intervalstyle on every connection with a @SET@ command,
495+-- but for better performance you may want to configure it permanently in the
496+-- file found with @SHOW config_file;@ .
497+--
498+instance FromField CalendarDiffTime where
499+ fromField = ff TI.intervalOid "CalendarDiffTime" parseCalendarDiffTime
477500
478501ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a)
479502 -> Field -> Maybe B8.ByteString -> Conversion a
480−ff compatOid hsType parse f mstr =
503+ff compatOid hsType parseBS f mstr =
481504 if typeOid f /= compatOid
482505 then err Incompatible ""
483506 else case mstr of
484507 Nothing -> err UnexpectedNull ""
485− Just str -> case parse str of
508+ Just str -> case parseBS str of
486509 Left msg -> err ConversionFailed msg
487510 Right val -> return val
488511 where
@@ -520,10 +543,10 @@ pgArrayFieldParser fieldParser f mdat = do
520543 _ -> returnError Incompatible f ""
521544
522545fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a])
523−fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim
546+fromArray fieldParser typInfo f = sequence . (parseIt <$>) <$> array delim
524547 where
525− delim = typdelim (typelem typeInfo)
526− fElem = f{ typeOid = typoid (typelem typeInfo) }
548+ delim = typdelim (typelem typInfo)
549+ fElem = f{ typeOid = typoid (typelem typInfo) }
527550
528551 parseIt item =
529552 fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item'
@@ -541,7 +564,7 @@ instance (FromField a, Typeable a) => FromField (IOVector a) where
541564-- | uuid
542565instance FromField UUID where
543566 fromField f mbs =
544− if typeOid f /= $(inlineTypoid TI.uuid)
567+ if typeOid f /= TI.uuidOid
545568 then returnError Incompatible f ""
546569 else case mbs of
547570 Nothing -> returnError UnexpectedNull f ""
@@ -550,20 +573,26 @@ instance FromField UUID where
550573 Nothing -> returnError ConversionFailed f "Invalid UUID"
551574 Just uuid -> pure uuid
552575
553−-- | json
576+-- | json, jsonb
554577instance FromField JSON.Value where
555− fromField f mbs =
556− if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb)
578+ fromField f mbs = parseBS =<< fromFieldJSONByteString f mbs
579+ where parseBS bs = case JSON.eitherDecodeStrict' bs of
580+ Left err -> returnError ConversionFailed f err
581+ Right val -> pure val
582+
583+-- | Return the JSON ByteString directly
584+--
585+-- @since 0.6.3
586+fromFieldJSONByteString :: Field -> Maybe ByteString -> Conversion ByteString
587+fromFieldJSONByteString f mbs =
588+ if typeOid f /= TI.jsonOid && typeOid f /= TI.jsonbOid
557589 then returnError Incompatible f ""
558590 else case mbs of
559591 Nothing -> returnError UnexpectedNull f ""
560− Just bs ->
561− case parseOnly (JSON.value' <* endOfInput) bs of
562− Left err -> returnError ConversionFailed f err
563− Right val -> pure val
592+ Just bs -> pure bs
564593
565594-- | Parse a field to a JSON 'JSON.Value' and convert that into a
566−-- Haskell value using 'JSON.fromJSON'.
595+-- Haskell value using the 'JSON.FromJSON' instance.
567596--
568597-- This can be used as the default implementation for the 'fromField'
569598-- method for Haskell types that have a JSON representation in
@@ -584,10 +613,10 @@ instance FromField JSON.Value where
584613fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a
585614fromJSONField f mbBs = do
586615 value <- fromField f mbBs
587− case JSON.fromJSON value of
588− JSON.Error err -> returnError ConversionFailed f $
589− "JSON decoding error: " ++ err
590− JSON.Success x -> pure x
616+ case JSON.ifromJSON value of
617+ JSON.IError path err -> returnError ConversionFailed f $
618+ "JSON decoding error: " ++ (JSON.formatError path err)
619+ JSON.ISuccess x -> pure x
591620
592621-- | Compatible with the same set of types as @a@. Note that
593622-- modifying the 'IORef' does not have any effects outside
@@ -604,20 +633,33 @@ instance FromField a => FromField (MVar a) where
604633type Compat = PQ.Oid -> Bool
605634
606635okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat
607−okText = $( mkCompats [ TI.name, TI.text, TI.char,
608− TI.bpchar, TI.varchar ] )
609−okText' = $( mkCompats [ TI.name, TI.text, TI.char,
610− TI.bpchar, TI.varchar, TI.unknown ] )
611−okBinary = (== $( inlineTypoid TI.bytea ))
612−ok16 = (== $( inlineTypoid TI.int2 ))
613−ok32 = $( mkCompats [TI.int2,TI.int4] )
614−ok64 = $( mkCompats [TI.int2,TI.int4,TI.int8] )
636+okText = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
637+ \/ eq TI.bpcharOid \/ eq TI.varcharOid
638+okText' = eq TI.nameOid \/ eq TI.textOid \/ eq TI.charOid
639+ \/ eq TI.bpcharOid \/ eq TI.varcharOid \/ eq TI.unknownOid
640+okBinary = eq TI.byteaOid
641+ok16 = eq TI.int2Oid
642+ok32 = eq TI.int2Oid \/ eq TI.int4Oid
643+ok64 = eq TI.int2Oid \/ eq TI.int4Oid \/ eq TI.int8Oid
615644#if WORD_SIZE_IN_BITS < 64
616645okInt = ok32
617646#else
618647okInt = ok64
619648#endif
620649
650+-- | eq and \/ are used to imlement what Macro stuff did,
651+-- i.e. mkCompats and inlineTypoid
652+eq :: PQ.Oid -> PQ.Oid -> Bool
653+eq = (==)
654+{-# INLINE eq #-}
655+
656+infixr 2 \/
657+(\/) :: (PQ.Oid -> Bool)
658+ -> (PQ.Oid -> Bool)
659+ -> (PQ.Oid -> Bool)
660+f \/ g = \x -> f x || g x
661+{-# INLINE (\/) #-}
662+
621663doFromField :: forall a . (Typeable a)
622664 => Field -> Compat -> (ByteString -> Conversion a)
623665 -> Maybe ByteString -> Conversion a
@@ -642,10 +684,22 @@ returnError mkErr f msg = do
642684 (show (typeOf (undefined :: a)))
643685 msg
644686
645−atto :: forall a. (Typeable a)
646− => Compat -> Parser a -> Field -> Maybe ByteString
647− -> Conversion a
648−atto types p0 f dat = doFromField f types (go p0) dat
687+-- | Construct a field parser from an attoparsec parser. An 'Incompatible' error is thrown if the
688+-- PostgreSQL oid does not match the specified predicate.
689+--
690+-- @
691+-- instance FromField Int16 where
692+-- fromField = attoFieldParser ok16 (signed decimal)
693+-- @
694+--
695+-- @since 0.6.3
696+attoFieldParser :: forall a. (Typeable a)
697+ => (PQ.Oid -> Bool)
698+ -- ^ Predicate for whether the postgresql type oid is compatible with this parser
699+ -> Parser a
700+ -- ^ An attoparsec parser.
701+ -> FieldParser a
702+attoFieldParser types p0 f dat = doFromField f types (go p0) dat
649703 where
650704 go :: Parser a -> ByteString -> Conversion a
651705 go p s =
src/Database/PostgreSQL/Simple/FromRow.hs+209−2
@@ -67,6 +67,23 @@ import GHC.Generics
6767-- in a single row of the query result. Otherwise, a 'ConversionFailed'
6868-- exception will be thrown.
6969--
70+-- You can also derive 'FromRow' for your data type using GHC generics, like
71+-- this:
72+--
73+-- @
74+-- \{-# LANGUAGE DeriveAnyClass \#-}
75+-- \{-# LANGUAGE DeriveGeneric \#-}
76+--
77+-- import "GHC.Generics" ('GHC.Generics.Generic')
78+-- import "Database.PostgreSQL.Simple" ('FromRow')
79+--
80+-- data User = User { name :: String, fileQuota :: Int }
81+-- deriving ('GHC.Generics.Generic', 'FromRow')
82+-- @
83+--
84+-- Note that this only works for product types (e.g. records) and does not
85+-- support sum types or recursive types.
86+--
7087-- Note that 'field' evaluates its result to WHNF, so the caveats listed in
7188-- mysql-simple and very early versions of postgresql-simple no longer apply.
7289-- Instead, look at the caveats associated with user-defined implementations
@@ -114,8 +131,8 @@ fieldWith fieldP = RP $ do
114131 else do
115132 let !result = rowresult
116133 !typeOid = unsafeDupablePerformIO (PQ.ftype result column)
117− !field = Field{..}
118− lift (lift (fieldP field (getvalue result row column)))
134+ !field' = Field{..}
135+ lift (lift (fieldP field' (getvalue result row column)))
119136
120137field :: FromField a => RowParser a
121138field = fieldWith fromField
@@ -238,6 +255,196 @@ instance (FromField a, FromField b, FromField c, FromField d, FromField e,
238255 null *> null *> null *> null *> null *> pure Nothing)
239256 <|> (Just <$> fromRow)
240257
258+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
259+ FromField f, FromField g, FromField h, FromField i, FromField j,
260+ FromField k) =>
261+ FromRow (a,b,c,d,e,f,g,h,i,j,k) where
262+ fromRow = (,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
263+ <*> field <*> field <*> field <*> field <*> field
264+ <*> field
265+
266+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
267+ FromField f, FromField g, FromField h, FromField i, FromField j,
268+ FromField k) =>
269+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k)) where
270+ fromRow = (null *> null *> null *> null *> null *>
271+ null *> null *> null *> null *> null *>
272+ null *> pure Nothing)
273+ <|> (Just <$> fromRow)
274+
275+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
276+ FromField f, FromField g, FromField h, FromField i, FromField j,
277+ FromField k, FromField l) =>
278+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where
279+ fromRow = (,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
280+ <*> field <*> field <*> field <*> field <*> field
281+ <*> field <*> field
282+
283+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
284+ FromField f, FromField g, FromField h, FromField i, FromField j,
285+ FromField k, FromField l) =>
286+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l)) where
287+ fromRow = (null *> null *> null *> null *> null *>
288+ null *> null *> null *> null *> null *>
289+ null *> null *> pure Nothing)
290+ <|> (Just <$> fromRow)
291+
292+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
293+ FromField f, FromField g, FromField h, FromField i, FromField j,
294+ FromField k, FromField l, FromField m) =>
295+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where
296+ fromRow = (,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
297+ <*> field <*> field <*> field <*> field <*> field
298+ <*> field <*> field <*> field
299+
300+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
301+ FromField f, FromField g, FromField h, FromField i, FromField j,
302+ FromField k, FromField l, FromField m) =>
303+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m)) where
304+ fromRow = (null *> null *> null *> null *> null *>
305+ null *> null *> null *> null *> null *>
306+ null *> null *> null *> pure Nothing)
307+ <|> (Just <$> fromRow)
308+
309+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
310+ FromField f, FromField g, FromField h, FromField i, FromField j,
311+ FromField k, FromField l, FromField m, FromField n) =>
312+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
313+ fromRow = (,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
314+ <*> field <*> field <*> field <*> field <*> field
315+ <*> field <*> field <*> field <*> field
316+
317+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
318+ FromField f, FromField g, FromField h, FromField i, FromField j,
319+ FromField k, FromField l, FromField m, FromField n) =>
320+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n)) where
321+ fromRow = (null *> null *> null *> null *> null *>
322+ null *> null *> null *> null *> null *>
323+ null *> null *> null *> null *> pure Nothing)
324+ <|> (Just <$> fromRow)
325+
326+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
327+ FromField f, FromField g, FromField h, FromField i, FromField j,
328+ FromField k, FromField l, FromField m, FromField n, FromField o) =>
329+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
330+ fromRow = (,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
331+ <*> field <*> field <*> field <*> field <*> field
332+ <*> field <*> field <*> field <*> field <*> field
333+
334+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
335+ FromField f, FromField g, FromField h, FromField i, FromField j,
336+ FromField k, FromField l, FromField m, FromField n, FromField o) =>
337+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)) where
338+ fromRow = (null *> null *> null *> null *> null *>
339+ null *> null *> null *> null *> null *>
340+ null *> null *> null *> null *> null *> pure Nothing)
341+ <|> (Just <$> fromRow)
342+
343+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
344+ FromField f, FromField g, FromField h, FromField i, FromField j,
345+ FromField k, FromField l, FromField m, FromField n, FromField o,
346+ FromField p) =>
347+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where
348+ fromRow = (,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
349+ <*> field <*> field <*> field <*> field <*> field
350+ <*> field <*> field <*> field <*> field <*> field
351+ <*> field
352+
353+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
354+ FromField f, FromField g, FromField h, FromField i, FromField j,
355+ FromField k, FromField l, FromField m, FromField n, FromField o,
356+ FromField p) =>
357+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)) where
358+ fromRow = (null *> null *> null *> null *> null *>
359+ null *> null *> null *> null *> null *>
360+ null *> null *> null *> null *> null *>
361+ null *> pure Nothing)
362+ <|> (Just <$> fromRow)
363+
364+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
365+ FromField f, FromField g, FromField h, FromField i, FromField j,
366+ FromField k, FromField l, FromField m, FromField n, FromField o,
367+ FromField p, FromField q) =>
368+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where
369+ fromRow = (,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
370+ <*> field <*> field <*> field <*> field <*> field
371+ <*> field <*> field <*> field <*> field <*> field
372+ <*> field <*> field
373+
374+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
375+ FromField f, FromField g, FromField h, FromField i, FromField j,
376+ FromField k, FromField l, FromField m, FromField n, FromField o,
377+ FromField p, FromField q) =>
378+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)) where
379+ fromRow = (null *> null *> null *> null *> null *>
380+ null *> null *> null *> null *> null *>
381+ null *> null *> null *> null *> null *>
382+ null *> null *> pure Nothing)
383+ <|> (Just <$> fromRow)
384+
385+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
386+ FromField f, FromField g, FromField h, FromField i, FromField j,
387+ FromField k, FromField l, FromField m, FromField n, FromField o,
388+ FromField p, FromField q, FromField r) =>
389+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where
390+ fromRow = (,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
391+ <*> field <*> field <*> field <*> field <*> field
392+ <*> field <*> field <*> field <*> field <*> field
393+ <*> field <*> field <*> field
394+
395+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
396+ FromField f, FromField g, FromField h, FromField i, FromField j,
397+ FromField k, FromField l, FromField m, FromField n, FromField o,
398+ FromField p, FromField q, FromField r) =>
399+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)) where
400+ fromRow = (null *> null *> null *> null *> null *>
401+ null *> null *> null *> null *> null *>
402+ null *> null *> null *> null *> null *>
403+ null *> null *> null *> pure Nothing)
404+ <|> (Just <$> fromRow)
405+
406+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
407+ FromField f, FromField g, FromField h, FromField i, FromField j,
408+ FromField k, FromField l, FromField m, FromField n, FromField o,
409+ FromField p, FromField q, FromField r, FromField s) =>
410+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where
411+ fromRow = (,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
412+ <*> field <*> field <*> field <*> field <*> field
413+ <*> field <*> field <*> field <*> field <*> field
414+ <*> field <*> field <*> field <*> field
415+
416+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
417+ FromField f, FromField g, FromField h, FromField i, FromField j,
418+ FromField k, FromField l, FromField m, FromField n, FromField o,
419+ FromField p, FromField q, FromField r, FromField s) =>
420+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)) where
421+ fromRow = (null *> null *> null *> null *> null *>
422+ null *> null *> null *> null *> null *>
423+ null *> null *> null *> null *> null *>
424+ null *> null *> null *> null *> pure Nothing)
425+ <|> (Just <$> fromRow)
426+
427+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
428+ FromField f, FromField g, FromField h, FromField i, FromField j,
429+ FromField k, FromField l, FromField m, FromField n, FromField o,
430+ FromField p, FromField q, FromField r, FromField s, FromField t) =>
431+ FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where
432+ fromRow = (,,,,,,,,,,,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field
433+ <*> field <*> field <*> field <*> field <*> field
434+ <*> field <*> field <*> field <*> field <*> field
435+ <*> field <*> field <*> field <*> field <*> field
436+
437+instance (FromField a, FromField b, FromField c, FromField d, FromField e,
438+ FromField f, FromField g, FromField h, FromField i, FromField j,
439+ FromField k, FromField l, FromField m, FromField n, FromField o,
440+ FromField p, FromField q, FromField r, FromField s, FromField t) =>
441+ FromRow (Maybe (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)) where
442+ fromRow = (null *> null *> null *> null *> null *>
443+ null *> null *> null *> null *> null *>
444+ null *> null *> null *> null *> null *>
445+ null *> null *> null *> null *> null *> pure Nothing)
446+ <|> (Just <$> fromRow)
447+
241448instance FromField a => FromRow [a] where
242449 fromRow = do
243450 n <- numFieldsRemaining
src/Database/PostgreSQL/Simple/HStore/Implementation.hs+11−11
@@ -22,9 +22,6 @@ import Data.ByteString.Builder (Builder, byteString, char8)
2222import qualified Data.ByteString.Builder as BU
2323import Data.ByteString.Internal (c2w, w2c)
2424import qualified Data.ByteString.Lazy as BL
25−#if !MIN_VERSION_bytestring(0,10,0)
26−import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks)
27−#endif
2825import Data.Map(Map)
2926import qualified Data.Map as Map
3027import Data.Text(Text)
@@ -34,6 +31,7 @@ import Data.Text.Encoding.Error(UnicodeException)
3431import qualified Data.Text.Lazy as TL
3532import Data.Typeable
3633import Data.Monoid(Monoid(..))
34+import Data.Semigroup
3735import Database.PostgreSQL.Simple.FromField
3836import Database.PostgreSQL.Simple.ToField
3937
@@ -52,26 +50,28 @@ instance ToHStore HStoreBuilder where
5250toBuilder :: HStoreBuilder -> Builder
5351toBuilder x = case x of
5452 Empty -> mempty
55− Comma x -> x
53+ Comma c -> c
5654
5755toLazyByteString :: HStoreBuilder -> BL.ByteString
5856toLazyByteString x = case x of
5957 Empty -> BL.empty
60− Comma x -> BU.toLazyByteString x
58+ Comma c -> BU.toLazyByteString c
6159
62−instance Monoid HStoreBuilder where
63− mempty = Empty
64− mappend Empty x = x
65− mappend (Comma a) x
60+instance Semigroup HStoreBuilder where
61+ Empty <> x = x
62+ Comma a <> x
6663 = Comma (a `mappend` case x of
6764 Empty -> mempty
6865 Comma b -> char8 ',' `mappend` b)
6966
67+instance Monoid HStoreBuilder where
68+ mempty = Empty
69+
7070class ToHStoreText a where
7171 toHStoreText :: a -> HStoreText
7272
7373-- | Represents escape text, ready to be the key or value to a hstore value
74−newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid)
74+newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid)
7575
7676instance ToHStoreText HStoreText where
7777 toHStoreText = id
@@ -144,7 +144,7 @@ newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Or
144144
145145instance ToHStore HStoreMap where
146146 toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs
147− where f k v xs = hstore k v `mappend` xs
147+ where f k v xs' = hstore k v `mappend` xs'
148148
149149instance ToField HStoreMap where
150150 toField xs = toField (toHStore xs)
src/Database/PostgreSQL/Simple/Internal.hs+67−16
@@ -1,5 +1,8 @@
11{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-}
2−{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE InstanceSigs #-}
36
47------------------------------------------------------------------------------
58-- |
@@ -33,7 +36,6 @@ import Data.Int (Int64)
3336import qualified Data.IntMap as IntMap
3437import Data.IORef
3538import Data.Maybe(fromMaybe)
36−import Data.Monoid
3739import Data.String
3840import qualified Data.Text as T
3941import qualified Data.Text.Encoding as TE
@@ -50,6 +52,7 @@ import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo)
5052import Control.Monad.Trans.State.Strict
5153import Control.Monad.Trans.Reader
5254import Control.Monad.Trans.Class
55+import GHC.Generics
5356import GHC.IO.Exception
5457#if !defined(mingw32_HOST_OS)
5558import Control.Concurrent(threadWaitRead, threadWaitWrite)
@@ -80,6 +83,25 @@ data Connection = Connection {
8083instance Eq Connection where
8184 x == y = connectionHandle x == connectionHandle y
8285
86+-- | Superclass for postgresql exceptions
87+data SomePostgreSqlException = forall e. Exception e => SomePostgreSqlException e
88+ deriving Typeable
89+
90+postgresqlExceptionToException :: Exception e => e -> SomeException
91+postgresqlExceptionToException = toException . SomePostgreSqlException
92+
93+postgresqlExceptionFromException :: Exception e => SomeException -> Maybe e
94+postgresqlExceptionFromException x = do
95+ SomePostgreSqlException a <- fromException x
96+ cast a
97+
98+instance Show SomePostgreSqlException where
99+ showsPrec :: Int -> SomePostgreSqlException -> ShowS
100+ showsPrec p (SomePostgreSqlException e) = showsPrec p e
101+
102+instance Exception SomePostgreSqlException where
103+ displayException (SomePostgreSqlException e) = displayException e
104+
83105data SqlError = SqlError {
84106 sqlState :: ByteString
85107 , sqlExecStatus :: ExecStatus
@@ -91,7 +113,10 @@ data SqlError = SqlError {
91113fatalError :: ByteString -> SqlError
92114fatalError msg = SqlError "" FatalError msg "" ""
93115
94−instance Exception SqlError
116+instance Exception SqlError where
117+ toException = postgresqlExceptionToException
118+ fromException = postgresqlExceptionFromException
119+
95120
96121-- | Exception thrown if 'query' is used to perform an @INSERT@-like
97122-- operation, or 'execute' is used to perform a @SELECT@-like operation.
@@ -100,7 +125,9 @@ data QueryError = QueryError {
100125 , qeQuery :: Query
101126 } deriving (Eq, Show, Typeable)
102127
103−instance Exception QueryError
128+instance Exception QueryError where
129+ toException = postgresqlExceptionToException
130+ fromException = postgresqlExceptionFromException
104131
105132-- | Exception thrown if a 'Query' could not be formatted correctly.
106133-- This may occur if the number of \'@?@\' characters in the query
@@ -111,7 +138,9 @@ data FormatError = FormatError {
111138 , fmtParams :: [ByteString]
112139 } deriving (Eq, Show, Typeable)
113140
114−instance Exception FormatError
141+instance Exception FormatError where
142+ toException = postgresqlExceptionToException
143+ fromException = postgresqlExceptionFromException
115144
116145data ConnectInfo = ConnectInfo {
117146 connectHost :: String
@@ -119,7 +148,7 @@ data ConnectInfo = ConnectInfo {
119148 , connectUser :: String
120149 , connectPassword :: String
121150 , connectDatabase :: String
122− } deriving (Eq,Read,Show,Typeable)
151+ } deriving (Generic,Eq,Read,Show,Typeable)
123152
124153-- | Default information for setting up a connection.
125154--
@@ -153,6 +182,12 @@ defaultConnectInfo = ConnectInfo {
153182connect :: ConnectInfo -> IO Connection
154183connect = connectPostgreSQL . postgreSQLConnectionString
155184
185+-- | Memory bracket around 'connect' and 'close'.
186+--
187+-- @since 0.6.5
188+withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c
189+withConnect connInfo = bracket (connect connInfo) close
190+
156191-- | Attempt to make a connection based on a libpq connection string.
157192-- See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING>
158193-- for more information. Also note that environment variables also affect
@@ -188,7 +223,8 @@ connect = connectPostgreSQL . postgreSQLConnectionString
188223--
189224-- Omitting @password@ will default to an appropriate password found
190225-- in the @pgpass@ file, or no password at all if a matching line is
191−-- not found. See
226+-- not found. The path of the @pgpass@ file may be specified by setting
227+-- the @PGPASSFILE@ environment variable. See
192228-- <https://www.postgresql.org/docs/9.5/static/libpq-pgpass.html> for
193229-- more information regarding this file.
194230--
@@ -287,7 +323,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
287323
288324 str name field
289325 | null value = id
290− | otherwise = showString name . quote value . space
326+ | otherwise = showString name . addQuotes value . space
291327 where value = field connectInfo
292328
293329 num name field
@@ -295,7 +331,7 @@ postgreSQLConnectionString connectInfo = fromString connstr
295331 | otherwise = showString name . shows value . space
296332 where value = field connectInfo
297333
298− quote str rest = '\'' : foldr delta ('\'' : rest) str
334+ addQuotes s rest = '\'' : foldr delta ('\'' : rest) s
299335 where
300336 delta c cs = case c of
301337 '\\' -> '\\' : '\\' : cs
@@ -351,6 +387,7 @@ exec conn sql =
351387 Just res -> do
352388 status <- PQ.resultStatus res
353389 case status of
390+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
354391 PQ.EmptyQuery -> getResult h mres'
355392 PQ.CommandOk -> getResult h mres'
356393 PQ.TuplesOk -> getResult h mres'
@@ -371,6 +408,7 @@ finishExecute :: Connection -> Query -> PQ.Result -> IO Int64
371408finishExecute _conn q result = do
372409 status <- PQ.resultStatus result
373410 case status of
411+ -- FIXME: handle PQ.CopyBoth and PQ.SingleTuple
374412 PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q
375413 PQ.CommandOk -> do
376414 ncols <- PQ.nfields result
@@ -381,7 +419,7 @@ finishExecute _conn q result = do
381419 nstr <- PQ.cmdTuples result
382420 return $ case nstr of
383421 Nothing -> 0 -- is this appropriate?
384− Just str -> toInteger str
422+ Just str -> mkInteger str
385423 PQ.TuplesOk -> do
386424 ncols <- PQ.nfields result
387425 throwIO $ QueryError ("execute resulted in " ++ show ncols ++
@@ -394,7 +432,7 @@ finishExecute _conn q result = do
394432 PQ.NonfatalError -> throwResultError "execute" result status
395433 PQ.FatalError -> throwResultError "execute" result status
396434 where
397− toInteger str = B8.foldl' delta 0 str
435+ mkInteger str = B8.foldl' delta 0 str
398436 where
399437 delta acc c =
400438 if '0' <= c && c <= '9'
@@ -409,8 +447,8 @@ throwResultError _ result status = do
409447 PQ.resultErrorField result PQ.DiagMessageDetail
410448 hint <- fromMaybe "" <$>
411449 PQ.resultErrorField result PQ.DiagMessageHint
412− state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
413− throwIO $ SqlError { sqlState = state
450+ state' <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate
451+ throwIO $ SqlError { sqlState = state'
414452 , sqlExecStatus = status
415453 , sqlErrorMsg = errormsg
416454 , sqlErrorDetail = detail
@@ -479,9 +517,6 @@ instance Alternative Conversion where
479517 Errors _ -> (oka <|>) <$> runConversion mb conn
480518
481519instance Monad Conversion where
482−#if !(MIN_VERSION_base(4,8,0))
483− return = pure
484−#endif
485520 m >>= f = Conversion $ \conn -> do
486521 oka <- runConversion m conn
487522 case oka of
@@ -584,3 +619,19 @@ escapeIdentifier = escapeWrap PQ.escapeIdentifier
584619
585620escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)
586621escapeByteaConn = escapeWrap PQ.escapeByteaConn
622+
623+breakOnSingleQuestionMark :: ByteString -> (ByteString, ByteString)
624+breakOnSingleQuestionMark b = go (B8.empty, b)
625+ where go (x,bs) = (x `B8.append` x',bs')
626+ -- seperate from first QM
627+ where tup@(noQ, restWithQ) = B8.break (=='?') bs
628+ -- if end of query, just return
629+ -- else check for second QM in 'go2'
630+ (x', bs') = maybe tup go2 $
631+ -- drop found QM and peek at next char
632+ B8.uncons restWithQ >>= B8.uncons . snd
633+ -- another QM after the first means:
634+ -- take literal QM and keep going.
635+ go2 ('?', t2) = go (noQ `B8.snoc` '?',t2)
636+ -- Anything else means
637+ go2 _ = tup
src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hsnew file+123
@@ -0,0 +1,123 @@
1+{-# LANGUAGE CPP #-}
2+
3+------------------------------------------------------------------------------
4+-- |
5+-- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils
6+-- Copyright: (c) 2011 MailRank, Inc.
7+-- (c) 2011-2012 Leon P Smith
8+-- License: BSD3
9+-- Maintainer: Leon P Smith <leon@melding-monads.com>
10+-- Stability: experimental
11+--
12+------------------------------------------------------------------------------
13+
14+
15+module Database.PostgreSQL.Simple.Internal.PQResultUtils
16+ ( finishQueryWith
17+ , finishQueryWithV
18+ , finishQueryWithVU
19+ , getRowWith
20+ ) where
21+
22+import Control.Exception as E
23+import Data.ByteString (ByteString)
24+import Data.Foldable (for_)
25+import Database.PostgreSQL.Simple.FromField (ResultError(..))
26+import Database.PostgreSQL.Simple.Ok
27+import Database.PostgreSQL.Simple.Types (Query(..))
28+import Database.PostgreSQL.Simple.Internal as Base hiding (result, row)
29+import Database.PostgreSQL.Simple.TypeInfo
30+import qualified Database.PostgreSQL.LibPQ as PQ
31+import qualified Data.ByteString.Char8 as B
32+import qualified Data.Vector as V
33+import qualified Data.Vector.Mutable as MV
34+import qualified Data.Vector.Unboxed as VU
35+import qualified Data.Vector.Unboxed.Mutable as MVU
36+import Control.Monad.Trans.Reader
37+import Control.Monad.Trans.State.Strict
38+
39+finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r]
40+finishQueryWith parser conn q result = finishQueryWith' q result $ do
41+ nrows <- PQ.ntuples result
42+ ncols <- PQ.nfields result
43+ forM' 0 (nrows-1) $ \row ->
44+ getRowWith parser row ncols conn result
45+
46+finishQueryWithV :: RowParser r -> Connection -> Query -> PQ.Result -> IO (V.Vector r)
47+finishQueryWithV parser conn q result = finishQueryWith' q result $ do
48+ nrows <- PQ.ntuples result
49+ let PQ.Row nrows' = nrows
50+ ncols <- PQ.nfields result
51+ mv <- MV.unsafeNew (fromIntegral nrows')
52+ for_ [ 0 .. nrows-1 ] $ \row -> do
53+ let PQ.Row row' = row
54+ value <- getRowWith parser row ncols conn result
55+ MV.unsafeWrite mv (fromIntegral row') value
56+ V.unsafeFreeze mv
57+
58+finishQueryWithVU :: VU.Unbox r => RowParser r -> Connection -> Query -> PQ.Result -> IO (VU.Vector r)
59+finishQueryWithVU parser conn q result = finishQueryWith' q result $ do
60+ nrows <- PQ.ntuples result
61+ let PQ.Row nrows' = nrows
62+ ncols <- PQ.nfields result
63+ mv <- MVU.unsafeNew (fromIntegral nrows')
64+ for_ [ 0 .. nrows-1 ] $ \row -> do
65+ let PQ.Row row' = row
66+ value <- getRowWith parser row ncols conn result
67+ MVU.unsafeWrite mv (fromIntegral row') value
68+ VU.unsafeFreeze mv
69+
70+finishQueryWith' :: Query -> PQ.Result -> IO a -> IO a
71+finishQueryWith' q result k = do
72+ status <- PQ.resultStatus result
73+ case status of
74+ PQ.TuplesOk -> k
75+ PQ.EmptyQuery -> queryErr "query: Empty query"
76+ PQ.CommandOk -> queryErr "query resulted in a command response (did you mean to use `execute` or forget a RETURNING?)"
77+ PQ.CopyOut -> queryErr "query: COPY TO is not supported"
78+ PQ.CopyIn -> queryErr "query: COPY FROM is not supported"
79+ PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported"
80+ PQ.SingleTuple -> queryErr "query: single-row mode is not supported"
81+ PQ.BadResponse -> throwResultError "query" result status
82+ PQ.NonfatalError -> throwResultError "query" result status
83+ PQ.FatalError -> throwResultError "query" result status
84+ where
85+ queryErr msg = throwIO $ QueryError msg q
86+
87+getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r
88+getRowWith parser row ncols conn result = do
89+ let rw = Row row result
90+ let unCol (PQ.Col x) = fromIntegral x :: Int
91+ okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn
92+ case okvc of
93+ Ok (val,col) | col == ncols -> return val
94+ | otherwise -> do
95+ vals <- forM' 0 (ncols-1) $ \c -> do
96+ tinfo <- getTypeInfo conn =<< PQ.ftype result c
97+ v <- PQ.getvalue result row c
98+ return ( tinfo
99+ , fmap ellipsis v )
100+ throw (ConversionFailed
101+ (show (unCol ncols) ++ " values: " ++ show vals)
102+ Nothing
103+ ""
104+ (show (unCol col) ++ " slots in target type")
105+ "mismatch between number of columns to convert and number in target type")
106+ Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error"
107+ Errors [x] -> throwIO x
108+ Errors xs -> throwIO $ ManyErrors xs
109+
110+ellipsis :: ByteString -> ByteString
111+ellipsis bs
112+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"
113+ | otherwise = bs
114+
115+forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]
116+forM' lo hi m = loop hi []
117+ where
118+ loop !n !as
119+ | n < lo = return as
120+ | otherwise = do
121+ a <- m n
122+ loop (n-1) (a:as)
123+{-# INLINE forM' #-}
src/Database/PostgreSQL/Simple/Newtypes.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+-- | Module with newtypes suitable to usage with @DerivingVia@ or standalone.
4+--
5+-- The newtypes are named after packages they wrap.
6+module Database.PostgreSQL.Simple.Newtypes (
7+ Aeson (..), getAeson,
8+) where
9+
10+import Data.Typeable (Typeable)
11+import Database.PostgreSQL.Simple.ToField (ToField (..))
12+import Database.PostgreSQL.Simple.FromField (FromField (..), fromJSONField)
13+
14+import qualified Data.Aeson as Aeson
15+
16+-------------------------------------------------------------------------------
17+-- aeson
18+-------------------------------------------------------------------------------
19+
20+-- | A newtype wrapper with 'ToField' and 'FromField' instances
21+-- based on 'Aeson.ToJSON' and 'Aeson.FromJSON' type classes from @aeson@.
22+--
23+-- Example using @DerivingVia@:
24+--
25+-- @
26+-- data Foo = Foo Int String
27+-- deriving stock (Eq, Show, Generic) -- GHC built int
28+-- deriving anyclass ('Aeson.FromJSON', 'Aeson.ToJSON') -- Derived using GHC Generics
29+-- deriving ('ToField', 'FromField') via 'Aeson' Foo -- DerivingVia
30+-- @
31+--
32+-- Example using 'Aeson' newtype directly, for more ad-hoc queries
33+--
34+-- @
35+-- execute conn "INSERT INTO tbl (fld) VALUES (?)" (Only ('Aeson' x))
36+-- @
37+--
38+-- @since 0.6.3
39+newtype Aeson a = Aeson a
40+ deriving (Eq, Show, Read, Typeable, Functor)
41+
42+getAeson :: Aeson a -> a
43+getAeson (Aeson a) = a
44+
45+instance Aeson.ToJSON a => ToField (Aeson a) where
46+ toField = toField . Aeson.encode . getAeson
47+
48+instance (Aeson.FromJSON a, Typeable a) => FromField (Aeson a) where
49+ fromField f bs = fmap Aeson (fromJSONField f bs)
src/Database/PostgreSQL/Simple/Notification.hs−17
@@ -47,8 +47,6 @@ import GHC.IO.Exception ( ioe_location )
4747
4848#if defined(mingw32_HOST_OS)
4949import Control.Concurrent ( threadDelay )
50−#elif !MIN_VERSION_base(4,7,0)
51−import Control.Concurrent ( threadWaitRead )
5250#else
5351import GHC.Conc ( atomically )
5452import Control.Concurrent ( threadWaitReadSTM )
@@ -94,21 +92,6 @@ getNotification conn = join $ withConnection conn fetch
9492 -- with async exceptions, whereas threadDelay can.
9593 Just _fd -> do
9694 return (threadDelay 1000000 >> loop)
97−#elif !MIN_VERSION_base(4,7,0)
98− -- Technically there's a race condition that is usually benign.
99− -- If the connection is closed or reset after we drop the
100− -- lock, and then the fd index is reallocated to a new
101− -- descriptor before we call threadWaitRead, then
102− -- we could end up waiting on the wrong descriptor.
103− --
104− -- Now, if the descriptor becomes readable promptly, then
105− -- it's no big deal as we'll wake up and notice the change
106− -- on the next iteration of the loop. But if are very
107− -- unlucky, then we could end up waiting a long time.
108− Just fd -> do
109− return $ do
110− threadWaitRead fd `catch` (throwIO . setIOErrorLocation)
111− loop
11295#else
11396 -- This case fixes the race condition above. By registering
11497 -- our interest in the descriptor before we drop the lock,
src/Database/PostgreSQL/Simple/Ok.hs+7−4
@@ -37,6 +37,8 @@ import Control.Exception
3737import Control.Monad(MonadPlus(..))
3838import Data.Typeable
3939
40+import qualified Control.Monad.Fail as Fail
41+
4042-- FIXME: [SomeException] should probably be something else, maybe
4143-- a difference list (or a tree?)
4244
@@ -70,13 +72,14 @@ instance MonadPlus Ok where
7072 mplus = (<|>)
7173
7274instance Monad Ok where
73−#if !(MIN_VERSION_base(4,8,0))
74− return = pure
75−#endif
76−
7775 Errors es >>= _ = Errors es
7876 Ok a >>= f = f a
7977
78+#if !(MIN_VERSION_base(4,13,0))
79+ fail = Fail.fail
80+#endif
81+
82+instance Fail.MonadFail Ok where
8083 fail str = Errors [SomeException (ErrorCall str)]
8184
8285-- | a way to reify a list of exceptions into a single exception
src/Database/PostgreSQL/Simple/Range.hs+14−10
@@ -19,6 +19,7 @@ module Database.PostgreSQL.Simple.Range
1919 , empty
2020 , isEmpty, isEmptyBy
2121 , contains, containsBy
22+ , fromFieldRange
2223 ) where
2324
2425import Control.Applicative hiding (empty)
@@ -37,7 +38,7 @@ import Data.Monoid (mempty)
3738import Data.Scientific (Scientific)
3839import qualified Data.Text.Lazy.Builder as LT
3940import qualified Data.Text.Lazy.Encoding as LT
40−import Data.Time (Day, LocalTime,
41+import Data.Time.Compat (Day, LocalTime,
4142 NominalDiffTime,
4243 TimeOfDay, UTCTime,
4344 ZonedTime,
@@ -109,19 +110,19 @@ containsBy cmp rng x =
109110 PGRange _lb NegInfinity -> False
110111 PGRange lb ub -> checkLB lb x && checkUB ub x
111112 where
112− checkLB lb x =
113+ checkLB lb y =
113114 case lb of
114115 NegInfinity -> True
115116 PosInfinity -> False
116− Inclusive a -> cmp a x /= GT
117− Exclusive a -> cmp a x == LT
117+ Inclusive a -> cmp a y /= GT
118+ Exclusive a -> cmp a y == LT
118119
119− checkUB ub x =
120+ checkUB ub y =
120121 case ub of
121122 NegInfinity -> False
122123 PosInfinity -> True
123− Inclusive z -> cmp x z /= GT
124− Exclusive z -> cmp x z == LT
124+ Inclusive z -> cmp y z /= GT
125+ Exclusive z -> cmp y z == LT
125126
126127lowerBound :: Parser (a -> RangeBound a)
127128lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive)
@@ -189,7 +190,10 @@ rangeToBuilderBy cmp f x =
189190
190191
191192instance (FromField a, Typeable a) => FromField (PGRange a) where
192− fromField f mdat = do
193+ fromField = fromFieldRange fromField
194+
195+fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a)
196+fromFieldRange fromField' f mdat = do
193197 info <- typeInfo f
194198 case info of
195199 Range{} ->
@@ -199,8 +203,8 @@ instance (FromField a, Typeable a) => FromField (PGRange a) where
199203 Just "empty" -> pure $ empty
200204 Just bs ->
201205 let parseIt NegInfinity = pure NegInfinity
202− parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v)
203− parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v)
206+ parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v)
207+ parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v)
204208 parseIt PosInfinity = pure PosInfinity
205209 in case parseOnly pgrange bs of
206210 Left e -> returnError ConversionFailed f e
src/Database/PostgreSQL/Simple/SqlQQ.hs+10−9
@@ -1,4 +1,9 @@
1+{-# LANGUAGE CPP #-}
2+#if __GLASGOW_HASKELL__ >= 800
3+{-# LANGUAGE TemplateHaskellQuotes #-}
4+#else
15{-# LANGUAGE TemplateHaskell #-}
6+#endif
27------------------------------------------------------------------------------
38-- |
49-- Module: Database.PostgreSQL.Simple.SqlQQ
@@ -30,7 +35,7 @@ import Data.String
3035-- > (beginTime,endTime,string)
3136--
3237-- This quasiquoter returns a literal string expression of type 'Query',
33−-- and attempts to mimimize whitespace; otherwise the above query would
38+-- and attempts to minimize whitespace; otherwise the above query would
3439-- consist of approximately half whitespace when sent to the database
3540-- backend. It also recognizes and strips out standard sql comments "--".
3641--
@@ -52,13 +57,10 @@ import Data.String
5257
5358sql :: QuasiQuoter
5459sql = QuasiQuoter
55− { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
56− \ quasiquoter used in pattern context"
57− , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
58− \ quasiquoter used in type context"
60+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in pattern context"
61+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in type context"
5962 , quoteExp = sqlExp
60− , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
61− \ quasiquoter used in declaration context"
63+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql: quasiquoter used in declaration context"
6264 }
6365
6466sqlExp :: String -> Q Exp
@@ -85,5 +87,4 @@ minimizeSpace = drop 1 . reduceSpace
8587 instring ('\'':'\'':xs) = '\'':'\'': instring xs
8688 instring ('\'':xs) = '\'': insql xs
8789 instring (x:xs) = x : instring xs
88− instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\
89− \ string literal not terminated"
90+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql: string literal not terminated"
src/Database/PostgreSQL/Simple/Time.hs+2
@@ -227,6 +227,7 @@ module Database.PostgreSQL.Simple.Time
227227 , parseUTCTimestamp
228228 , parseZonedTimestamp
229229 , parseLocalTimestamp
230+ , parseCalendarDiffTime
230231 , dayToBuilder
231232 , utcTimeToBuilder
232233 , zonedTimeToBuilder
@@ -239,6 +240,7 @@ module Database.PostgreSQL.Simple.Time
239240 , localTimestampToBuilder
240241 , unboundedToBuilder
241242 , nominalDiffTimeToBuilder
243+ , calendarDiffTimeToBuilder
242244 ) where
243245
244246import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/Time/Implementation.hs+11−1
@@ -18,7 +18,8 @@ import Data.ByteString.Builder.Prim(primBounded)
1818import Control.Arrow((***))
1919import Control.Applicative
2020import qualified Data.ByteString as B
21−import Data.Time hiding (getTimeZone, getZonedTime)
21+import Data.Time.Compat (LocalTime, UTCTime, ZonedTime, Day, TimeOfDay, TimeZone, NominalDiffTime, utc)
22+import Data.Time.LocalTime.Compat (CalendarDiffTime)
2223import Data.Typeable
2324import Data.Maybe (fromMaybe)
2425import qualified Data.Attoparsec.ByteString.Char8 as A
@@ -77,6 +78,9 @@ parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
7778parseDate :: B.ByteString -> Either String Date
7879parseDate = A.parseOnly (getDate <* A.endOfInput)
7980
81+parseCalendarDiffTime :: B.ByteString -> Either String CalendarDiffTime
82+parseCalendarDiffTime = A.parseOnly (getCalendarDiffTime <* A.endOfInput)
83+
8084getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
8185getUnbounded getFinite
8286 = (pure NegInfinity <* A.string "-infinity")
@@ -125,6 +129,9 @@ getUTCTime = TP.utcTime
125129getUTCTimestamp :: A.Parser UTCTimestamp
126130getUTCTimestamp = getUnbounded getUTCTime
127131
132+getCalendarDiffTime :: A.Parser CalendarDiffTime
133+getCalendarDiffTime = TP.calendarDiffTime
134+
128135dayToBuilder :: Day -> Builder
129136dayToBuilder = primBounded TPP.day
130137
@@ -164,3 +171,6 @@ dateToBuilder = unboundedToBuilder dayToBuilder
164171
165172nominalDiffTimeToBuilder :: NominalDiffTime -> Builder
166173nominalDiffTimeToBuilder = TPP.nominalDiffTime
174+
175+calendarDiffTimeToBuilder :: CalendarDiffTime -> Builder
176+calendarDiffTimeToBuilder = TPP.calendarDiffTime
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+12−3
@@ -21,20 +21,24 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser
2121 , localToUTCTimeOfDayHMS
2222 , utcTime
2323 , zonedTime
24+ , calendarDiffTime
2425 ) where
2526
2627import Control.Applicative ((<$>), (<*>), (<*), (*>))
2728import Database.PostgreSQL.Simple.Compat (toPico)
2829import Data.Attoparsec.ByteString.Char8 as A
2930import Data.Bits ((.&.))
31+import Data.ByteString (ByteString)
3032import Data.Char (ord)
3133import Data.Fixed (Pico)
3234import Data.Int (Int64)
3335import Data.Maybe (fromMaybe)
34−import Data.Time.Calendar (Day, fromGregorianValid, addDays)
35−import Data.Time.Clock (UTCTime(..))
36+import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)
37+import Data.Time.Clock.Compat (UTCTime(..))
38+import Data.Time.Format.ISO8601.Compat (iso8601ParseM)
39+import Data.Time.LocalTime.Compat (CalendarDiffTime)
3640import qualified Data.ByteString.Char8 as B8
37−import qualified Data.Time.LocalTime as Local
41+import qualified Data.Time.LocalTime.Compat as Local
3842
3943-- | Parse a date of the form @YYYY-MM-DD@.
4044day :: Parser Day
@@ -193,3 +197,8 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
193197
194198utc :: Local.TimeZone
195199utc = Local.TimeZone 0 False ""
200+
201+calendarDiffTime :: Parser CalendarDiffTime
202+calendarDiffTime = do
203+ contents <- takeByteString
204+ iso8601ParseM $ B8.unpack contents
src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs+15−3
@@ -17,19 +17,23 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer
1717 , localTime
1818 , zonedTime
1919 , nominalDiffTime
20+ , calendarDiffTime
2021 ) where
2122
2223import Control.Arrow ((>>>))
23−import Data.ByteString.Builder (Builder, integerDec)
24+import Data.ByteString.Builder (Builder, byteString, integerDec)
2425import Data.ByteString.Builder.Prim
2526 ( liftFixedToBounded, (>$<), (>*<)
2627 , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)
2728import Data.Char ( chr )
2829import Data.Int ( Int32, Int64 )
29−import Data.Time
30+import Data.String (fromString)
31+import Data.Time.Compat
3032 ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime
3133 , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay
3234 , TimeZone, timeZoneMinutes )
35+import Data.Time.Format.ISO8601.Compat (iso8601Show)
36+import Data.Time.LocalTime.Compat (CalendarDiffTime)
3337import Database.PostgreSQL.Simple.Compat ((<>), fromPico)
3438import Unsafe.Coerce (unsafeCoerce)
3539
@@ -71,7 +75,7 @@ frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))
7175
7276
7377year :: BoundedPrim Int32
74−year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4)
78+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)
7579 where
7680 checkBCE :: Int32 -> Int
7781 checkBCE y
@@ -121,3 +125,11 @@ nominalDiffTime :: NominalDiffTime -> Builder
121125nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))
122126 where
123127 (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000
128+
129+calendarDiffTime :: CalendarDiffTime -> Builder
130+calendarDiffTime = byteString
131+ . fromString
132+ -- from the docs: "Beware: fromString truncates multi-byte characters to octets".
133+ -- However, I think this is a safe usage, because ISO8601-encoding seems restricted
134+ -- to ASCII output.
135+ . iso8601Show
src/Database/PostgreSQL/Simple/ToField.hs+33−11
@@ -1,5 +1,6 @@
11{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
22{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
3+{-# LANGUAGE PolyKinds #-}
34
45------------------------------------------------------------------------------
56-- |
@@ -22,6 +23,7 @@ module Database.PostgreSQL.Simple.ToField
2223 , inQuotes
2324 ) where
2425
26+import Control.Applicative (Const(Const))
2527import qualified Data.Aeson as JSON
2628import Data.ByteString (ByteString)
2729import Data.ByteString.Builder
@@ -30,10 +32,12 @@ import Data.ByteString.Builder
3032 , wordDec, word8Dec, word16Dec, word32Dec, word64Dec
3133 , floatDec, doubleDec
3234 )
35+import Data.Functor.Identity (Identity(Identity))
3336import Data.Int (Int8, Int16, Int32, Int64)
3437import Data.List (intersperse)
3538import Data.Monoid (mappend)
36−import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
39+import Data.Time.Compat (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime)
40+import Data.Time.LocalTime.Compat (CalendarDiffTime)
3741import Data.Typeable (Typeable)
3842import Data.Word (Word, Word8, Word16, Word32, Word64)
3943import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow
@@ -42,6 +46,8 @@ import Database.PostgreSQL.Simple.Compat (toByteString)
4246
4347import qualified Data.ByteString as SB
4448import qualified Data.ByteString.Lazy as LB
49+import Data.CaseInsensitive (CI)
50+import qualified Data.CaseInsensitive as CI
4551import qualified Data.Text as ST
4652import qualified Data.Text.Encoding as ST
4753import qualified Data.Text.Lazy as LT
@@ -53,11 +59,7 @@ import qualified Data.Vector as V
5359import qualified Database.PostgreSQL.LibPQ as PQ
5460import Database.PostgreSQL.Simple.Time
5561import Data.Scientific (Scientific)
56−#if MIN_VERSION_scientific(0,3,0)
5762import Data.Text.Lazy.Builder.Scientific (scientificBuilder)
58−#else
59−import Data.Scientific (scientificBuilder)
60−#endif
6163import Foreign.C.Types (CUInt(..))
6264
6365-- | How to render an element when substituting it into a query.
@@ -98,6 +100,14 @@ instance ToField Action where
98100 toField a = a
99101 {-# INLINE toField #-}
100102
103+instance (ToField a) => ToField (Const a b) where
104+ toField (Const a) = toField a
105+ {-# INLINE toField #-}
106+
107+instance (ToField a) => ToField (Identity a) where
108+ toField (Identity a) = toField a
109+ {-# INLINE toField #-}
110+
101111instance (ToField a) => ToField (Maybe a) where
102112 toField Nothing = renderNull
103113 toField (Just a) = toField a
@@ -230,6 +240,15 @@ instance ToField LT.Text where
230240 toField = toField . LT.toStrict
231241 {-# INLINE toField #-}
232242
243+-- | citext
244+instance ToField (CI ST.Text) where
245+ toField = toField . CI.original
246+ {-# INLINE toField #-}
247+
248+-- | citext
249+instance ToField (CI LT.Text) where
250+ toField = toField . LT.toStrict . CI.original
251+ {-# INLINE toField #-}
233252
234253instance ToField UTCTime where
235254 toField = Plain . inQuotes . utcTimeToBuilder
@@ -271,6 +290,10 @@ instance ToField NominalDiffTime where
271290 toField = Plain . inQuotes . nominalDiffTimeToBuilder
272291 {-# INLINE toField #-}
273292
293+instance ToField CalendarDiffTime where
294+ toField = Plain . inQuotes . calendarDiffTimeToBuilder
295+ {-# INLINE toField #-}
296+
274297instance (ToField a) => ToField (PGArray a) where
275298 toField pgArray =
276299 case fromPGArray pgArray of
@@ -291,14 +314,13 @@ instance ToField UUID where
291314instance ToField JSON.Value where
292315 toField = toField . JSON.encode
293316
294−-- | Convert a Haskell value to a JSON 'JSON.Value' using
295−-- 'JSON.toJSON' and convert that to a field using 'toField'.
317+-- | Convert a Haskell value to JSON using 'JSON.toEncoding'.
296318--
297319-- This can be used as the default implementation for the 'toField'
298320-- method for Haskell types that have a JSON representation in
299321-- PostgreSQL.
300322toJSONField :: JSON.ToJSON a => a -> Action
301−toJSONField = toField . JSON.toJSON
323+toJSONField = toField . JSON.encode
302324
303325-- | Surround a string with single-quote characters: \"@'@\"
304326--
@@ -308,7 +330,7 @@ inQuotes b = quote `mappend` b `mappend` quote
308330 where quote = char8 '\''
309331
310332interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]
311−interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as
333+interleaveFoldr f b bs' as = foldr (\a bs -> b : f a bs) bs' as
312334{-# INLINE interleaveFoldr #-}
313335
314336instance ToRow a => ToField (Values a) where
@@ -355,8 +377,8 @@ instance ToRow a => ToField (Values a) where
355377
356378 typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]
357379 typedRows [] _ _ = error funcname
358− typedRows (val:vals) types rest =
359− typedRow (toRow val) types (multiRows vals rest)
380+ typedRows (val:vals) typs rest =
381+ typedRow (toRow val) typs (multiRows vals rest)
360382
361383 untypedRows :: ToRow a => [a] -> [Action] -> [Action]
362384 untypedRows [] _ = error funcname
src/Database/PostgreSQL/Simple/ToRow.hs+106
@@ -30,6 +30,22 @@ import GHC.Generics
3030--
3131-- Instances should use the 'toField' method of the 'ToField' class
3232-- to perform conversion of each element of the collection.
33+--
34+-- You can derive 'ToRow' for your data type using GHC generics, like this:
35+--
36+-- @
37+-- \{-# LANGUAGE DeriveAnyClass \#-}
38+-- \{-# LANGUAGE DeriveGeneric \#-}
39+--
40+-- import "GHC.Generics" ('GHC.Generics.Generic')
41+-- import "Database.PostgreSQL.Simple" ('ToRow')
42+--
43+-- data User = User { name :: String, fileQuota :: Int }
44+-- deriving ('GHC.Generics.Generic', 'ToRow')
45+-- @
46+--
47+-- Note that this only works for product types (e.g. records) and does not
48+-- support sum types or recursive types.
3349class ToRow a where
3450 toRow :: a -> [Action]
3551 default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action]
@@ -89,6 +105,96 @@ instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
89105 [toField a, toField b, toField c, toField d, toField e, toField f,
90106 toField g, toField h, toField i, toField j]
91107
108+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
109+ ToField g, ToField h, ToField i, ToField j, ToField k)
110+ => ToRow (a,b,c,d,e,f,g,h,i,j,k) where
111+ toRow (a,b,c,d,e,f,g,h,i,j,k) =
112+ [toField a, toField b, toField c, toField d, toField e, toField f,
113+ toField g, toField h, toField i, toField j, toField k]
114+
115+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
116+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l)
117+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where
118+ toRow (a,b,c,d,e,f,g,h,i,j,k,l) =
119+ [toField a, toField b, toField c, toField d, toField e, toField f,
120+ toField g, toField h, toField i, toField j, toField k, toField l]
121+
122+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
123+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
124+ ToField m)
125+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where
126+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m) =
127+ [toField a, toField b, toField c, toField d, toField e, toField f,
128+ toField g, toField h, toField i, toField j, toField k, toField l,
129+ toField m]
130+
131+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
132+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
133+ ToField m, ToField n)
134+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
135+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =
136+ [toField a, toField b, toField c, toField d, toField e, toField f,
137+ toField g, toField h, toField i, toField j, toField k, toField l,
138+ toField m, toField n]
139+
140+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
141+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
142+ ToField m, ToField n, ToField o)
143+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
144+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =
145+ [toField a, toField b, toField c, toField d, toField e, toField f,
146+ toField g, toField h, toField i, toField j, toField k, toField l,
147+ toField m, toField n, toField o]
148+
149+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
150+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
151+ ToField m, ToField n, ToField o, ToField p)
152+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where
153+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) =
154+ [toField a, toField b, toField c, toField d, toField e, toField f,
155+ toField g, toField h, toField i, toField j, toField k, toField l,
156+ toField m, toField n, toField o, toField p]
157+
158+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
159+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
160+ ToField m, ToField n, ToField o, ToField p, ToField q)
161+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where
162+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) =
163+ [toField a, toField b, toField c, toField d, toField e, toField f,
164+ toField g, toField h, toField i, toField j, toField k, toField l,
165+ toField m, toField n, toField o, toField p, toField q]
166+
167+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
168+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
169+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r)
170+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where
171+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) =
172+ [toField a, toField b, toField c, toField d, toField e, toField f,
173+ toField g, toField h, toField i, toField j, toField k, toField l,
174+ toField m, toField n, toField o, toField p, toField q, toField r]
175+
176+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
177+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
178+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,
179+ ToField s)
180+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where
181+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) =
182+ [toField a, toField b, toField c, toField d, toField e, toField f,
183+ toField g, toField h, toField i, toField j, toField k, toField l,
184+ toField m, toField n, toField o, toField p, toField q, toField r,
185+ toField s]
186+
187+instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,
188+ ToField g, ToField h, ToField i, ToField j, ToField k, ToField l,
189+ ToField m, ToField n, ToField o, ToField p, ToField q, ToField r,
190+ ToField s, ToField t)
191+ => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where
192+ toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) =
193+ [toField a, toField b, toField c, toField d, toField e, toField f,
194+ toField g, toField h, toField i, toField j, toField k, toField l,
195+ toField m, toField n, toField o, toField p, toField q, toField r,
196+ toField s, toField t]
197+
92198instance (ToField a) => ToRow [a] where
93199 toRow = map toField
94200
src/Database/PostgreSQL/Simple/Transaction.hs+17−13
@@ -17,6 +17,7 @@ module Database.PostgreSQL.Simple.Transaction
1717 , withTransactionLevel
1818 , withTransactionMode
1919 , withTransactionModeRetry
20+ , withTransactionModeRetry'
2021 , withTransactionSerializable
2122 , TransactionMode(..)
2223 , IsolationLevel(..)
@@ -146,37 +147,40 @@ withTransactionMode mode conn act =
146147 commit conn
147148 return r
148149
150+-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
151+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
152+withTransactionModeRetry = withTransactionModeRetry'
153+
149154-- | Like 'withTransactionMode', but also takes a custom callback to
150−-- determine if a transaction should be retried if an 'SqlError' occurs.
151−-- If the callback returns True, then the transaction will be retried.
152−-- If the callback returns False, or an exception other than an 'SqlError'
155+-- determine if a transaction should be retried if an exception occurs.
156+-- If the callback returns 'True', then the transaction will be retried.
157+-- If the callback returns 'False', or an exception other than an @e@
153158-- occurs then the transaction will be rolled back and the exception rethrown.
154159--
155160-- This is used to implement 'withTransactionSerializable'.
156−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
157−withTransactionModeRetry mode shouldRetry conn act =
161+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
162+withTransactionModeRetry' mode shouldRetry conn act =
158163 mask $ \restore ->
159164 retryLoop $ E.try $ do
160− a <- restore act
165+ a <- restore act `E.onException` rollback_ conn
161166 commit conn
162167 return a
163168 where
164− retryLoop :: IO (Either E.SomeException a) -> IO a
169+ retryLoop :: IO (Either e a) -> IO a
165170 retryLoop act' = do
166171 beginMode mode conn
167172 r <- act'
168173 case r of
169− Left e -> do
170− rollback_ conn
171− case fmap shouldRetry (E.fromException e) of
172− Just True -> retryLoop act'
173− _ -> E.throwIO e
174+ Left e ->
175+ case shouldRetry e of
176+ True -> retryLoop act'
177+ False -> E.throwIO e
174178 Right a ->
175179 return a
176180
177181-- | Rollback a transaction.
178182rollback :: Connection -> IO ()
179−rollback conn = execute_ conn "ABORT" >> return ()
183+rollback conn = execute_ conn "ROLLBACK" >> return ()
180184
181185-- | Rollback a transaction, ignoring any @IOErrors@
182186rollback_ :: Connection -> IO ()
src/Database/PostgreSQL/Simple/TypeInfo.hs+9−9
@@ -50,21 +50,21 @@ import Database.PostgreSQL.Simple.TypeInfo.Static
5050-- in the connections's cache.
5151
5252getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo
53−getTypeInfo conn@Connection{..} oid =
54− case staticTypeInfo oid of
55− Just name -> return name
56− Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid
53+getTypeInfo conn@Connection{..} oid' =
54+ case staticTypeInfo oid' of
55+ Just name' -> return name'
56+ Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid'
5757
5858getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache
5959 -> IO (TypeInfoCache, TypeInfo)
60−getTypeInfo' conn oid oidmap =
61− case IntMap.lookup (oid2int oid) oidmap of
60+getTypeInfo' conn oid' oidmap =
61+ case IntMap.lookup (oid2int oid') oidmap of
6262 Just typeinfo -> return (oidmap, typeinfo)
6363 Nothing -> do
6464 names <- query conn "SELECT oid, typcategory, typdelim, typname,\
6565 \ typelem, typrelid\
6666 \ FROM pg_type WHERE oid = ?"
67− (Only oid)
67+ (Only oid')
6868 (oidmap', typeInfo) <-
6969 case names of
7070 [] -> return $ throw (fatalError "invalid type oid")
@@ -78,7 +78,7 @@ getTypeInfo' conn oid oidmap =
7878 rngsubtypeOids <- query conn "SELECT rngsubtype\
7979 \ FROM pg_range\
8080 \ WHERE rngtypid = ?"
81− (Only oid)
81+ (Only oid')
8282 case rngsubtypeOids of
8383 [Only rngsubtype_] -> do
8484 (oidmap', rngsubtype) <-
@@ -104,7 +104,7 @@ getTypeInfo' conn oid oidmap =
104104 _ -> fail "typename query returned more than one result"
105105 -- oid is a primary key, so the query should
106106 -- never return more than one result
107− let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap'
107+ let !oidmap'' = IntMap.insert (oid2int oid') typeInfo oidmap'
108108 return $! (oidmap'', typeInfo)
109109
110110getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache
src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs+9−3
@@ -1,4 +1,9 @@
1+{-# LANGUAGE CPP #-}
2+#if __GLASGOW_HASKELL__ >= 800
3+{-# LANGUAGE TemplateHaskellQuotes #-}
4+#else
15{-# LANGUAGE TemplateHaskell #-}
6+#endif
27
38------------------------------------------------------------------------------
49-- |
@@ -22,11 +27,12 @@ import Database.PostgreSQL.Simple.TypeInfo.Static
2227import Database.PostgreSQL.Simple.Types (Oid(..))
2328import Language.Haskell.TH
2429
25−
2630-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the
2731-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's.
2832mkCompats :: [TypeInfo] -> ExpQ
29−mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
33+mkCompats tys = do
34+ x <- newName "x"
35+ lamE [conP 'Oid [varP x]] $ caseE (varE x) (map alt tys ++ [catchAll])
3036 where
3137 alt :: TypeInfo -> MatchQ
3238 alt ty = match (inlineTypoidP ty) (normalB [| True |]) []
@@ -38,7 +44,7 @@ mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |]
3844-- Returns an expression of type 'Oid'. Useful because GHC tends
3945-- not to fold constants.
4046inlineTypoid :: TypeInfo -> ExpQ
41−inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |]
47+inlineTypoid ty = conE 'Oid `appE` litE (getTypoid ty)
4248
4349inlineTypoidP :: TypeInfo -> PatQ
4450inlineTypoidP ty = litP (getTypoid ty)
src/Database/PostgreSQL/Simple/TypeInfo/Static.hs+684−114
@@ -19,119 +19,233 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
1919 ( TypeInfo(..)
2020 , staticTypeInfo
2121 , bool
22+ , boolOid
2223 , bytea
24+ , byteaOid
2325 , char
26+ , charOid
2427 , name
28+ , nameOid
2529 , int8
30+ , int8Oid
2631 , int2
32+ , int2Oid
2733 , int4
34+ , int4Oid
2835 , regproc
36+ , regprocOid
2937 , text
38+ , textOid
3039 , oid
40+ , oidOid
3141 , tid
42+ , tidOid
3243 , xid
44+ , xidOid
3345 , cid
46+ , cidOid
3447 , xml
48+ , xmlOid
3549 , point
50+ , pointOid
3651 , lseg
52+ , lsegOid
3753 , path
54+ , pathOid
3855 , box
56+ , boxOid
3957 , polygon
58+ , polygonOid
4059 , line
60+ , lineOid
4161 , cidr
62+ , cidrOid
4263 , float4
64+ , float4Oid
4365 , float8
66+ , float8Oid
4467 , unknown
68+ , unknownOid
4569 , circle
70+ , circleOid
4671 , money
72+ , moneyOid
4773 , macaddr
74+ , macaddrOid
4875 , inet
76+ , inetOid
4977 , bpchar
78+ , bpcharOid
5079 , varchar
80+ , varcharOid
5181 , date
82+ , dateOid
5283 , time
84+ , timeOid
5385 , timestamp
86+ , timestampOid
5487 , timestamptz
88+ , timestamptzOid
5589 , interval
90+ , intervalOid
5691 , timetz
92+ , timetzOid
5793 , bit
94+ , bitOid
5895 , varbit
96+ , varbitOid
5997 , numeric
98+ , numericOid
6099 , refcursor
100+ , refcursorOid
61101 , record
102+ , recordOid
62103 , void
104+ , voidOid
63105 , array_record
106+ , array_recordOid
64107 , regprocedure
108+ , regprocedureOid
65109 , regoper
110+ , regoperOid
66111 , regoperator
112+ , regoperatorOid
67113 , regclass
114+ , regclassOid
68115 , regtype
116+ , regtypeOid
69117 , uuid
118+ , uuidOid
70119 , json
120+ , jsonOid
71121 , jsonb
122+ , jsonbOid
72123 , int2vector
124+ , int2vectorOid
73125 , oidvector
126+ , oidvectorOid
74127 , array_xml
128+ , array_xmlOid
75129 , array_json
130+ , array_jsonOid
76131 , array_line
132+ , array_lineOid
77133 , array_cidr
134+ , array_cidrOid
78135 , array_circle
136+ , array_circleOid
79137 , array_money
138+ , array_moneyOid
80139 , array_bool
140+ , array_boolOid
81141 , array_bytea
142+ , array_byteaOid
82143 , array_char
144+ , array_charOid
83145 , array_name
146+ , array_nameOid
84147 , array_int2
148+ , array_int2Oid
85149 , array_int2vector
150+ , array_int2vectorOid
86151 , array_int4
152+ , array_int4Oid
87153 , array_regproc
154+ , array_regprocOid
88155 , array_text
156+ , array_textOid
89157 , array_tid
158+ , array_tidOid
90159 , array_xid
160+ , array_xidOid
91161 , array_cid
162+ , array_cidOid
92163 , array_oidvector
164+ , array_oidvectorOid
93165 , array_bpchar
166+ , array_bpcharOid
94167 , array_varchar
168+ , array_varcharOid
95169 , array_int8
170+ , array_int8Oid
96171 , array_point
172+ , array_pointOid
97173 , array_lseg
174+ , array_lsegOid
98175 , array_path
176+ , array_pathOid
99177 , array_box
178+ , array_boxOid
100179 , array_float4
180+ , array_float4Oid
101181 , array_float8
182+ , array_float8Oid
102183 , array_polygon
184+ , array_polygonOid
103185 , array_oid
186+ , array_oidOid
104187 , array_macaddr
188+ , array_macaddrOid
105189 , array_inet
190+ , array_inetOid
106191 , array_timestamp
192+ , array_timestampOid
107193 , array_date
194+ , array_dateOid
108195 , array_time
196+ , array_timeOid
109197 , array_timestamptz
198+ , array_timestamptzOid
110199 , array_interval
200+ , array_intervalOid
111201 , array_numeric
202+ , array_numericOid
112203 , array_timetz
204+ , array_timetzOid
113205 , array_bit
206+ , array_bitOid
114207 , array_varbit
208+ , array_varbitOid
115209 , array_refcursor
210+ , array_refcursorOid
116211 , array_regprocedure
212+ , array_regprocedureOid
117213 , array_regoper
214+ , array_regoperOid
118215 , array_regoperator
216+ , array_regoperatorOid
119217 , array_regclass
218+ , array_regclassOid
120219 , array_regtype
220+ , array_regtypeOid
121221 , array_uuid
222+ , array_uuidOid
122223 , array_jsonb
224+ , array_jsonbOid
123225 , int4range
226+ , int4rangeOid
124227 , _int4range
228+ , _int4rangeOid
125229 , numrange
230+ , numrangeOid
126231 , _numrange
232+ , _numrangeOid
127233 , tsrange
234+ , tsrangeOid
128235 , _tsrange
236+ , _tsrangeOid
129237 , tstzrange
238+ , tstzrangeOid
130239 , _tstzrange
240+ , _tstzrangeOid
131241 , daterange
242+ , daterangeOid
132243 , _daterange
244+ , _daterangeOid
133245 , int8range
246+ , int8rangeOid
134247 , _int8range
248+ , _int8rangeOid
135249 ) where
136250
137251import Database.PostgreSQL.LibPQ (Oid(..))
@@ -257,976 +371,1432 @@ staticTypeInfo (Oid x) = case x of
257371
258372bool :: TypeInfo
259373bool = Basic {
260− typoid = Oid 16,
374+ typoid = boolOid,
261375 typcategory = 'B',
262376 typdelim = ',',
263377 typname = "bool"
264378 }
265379
380+boolOid :: Oid
381+boolOid = Oid 16
382+{-# INLINE boolOid #-}
383+
266384bytea :: TypeInfo
267385bytea = Basic {
268− typoid = Oid 17,
386+ typoid = byteaOid,
269387 typcategory = 'U',
270388 typdelim = ',',
271389 typname = "bytea"
272390 }
273391
392+byteaOid :: Oid
393+byteaOid = Oid 17
394+{-# INLINE byteaOid #-}
395+
274396char :: TypeInfo
275397char = Basic {
276− typoid = Oid 18,
398+ typoid = charOid,
277399 typcategory = 'S',
278400 typdelim = ',',
279401 typname = "char"
280402 }
281403
404+charOid :: Oid
405+charOid = Oid 18
406+{-# INLINE charOid #-}
407+
282408name :: TypeInfo
283409name = Basic {
284− typoid = Oid 19,
410+ typoid = nameOid,
285411 typcategory = 'S',
286412 typdelim = ',',
287413 typname = "name"
288414 }
289415
416+nameOid :: Oid
417+nameOid = Oid 19
418+{-# INLINE nameOid #-}
419+
290420int8 :: TypeInfo
291421int8 = Basic {
292− typoid = Oid 20,
422+ typoid = int8Oid,
293423 typcategory = 'N',
294424 typdelim = ',',
295425 typname = "int8"
296426 }
297427
428+int8Oid :: Oid
429+int8Oid = Oid 20
430+{-# INLINE int8Oid #-}
431+
298432int2 :: TypeInfo
299433int2 = Basic {
300− typoid = Oid 21,
434+ typoid = int2Oid,
301435 typcategory = 'N',
302436 typdelim = ',',
303437 typname = "int2"
304438 }
305439
440+int2Oid :: Oid
441+int2Oid = Oid 21
442+{-# INLINE int2Oid #-}
443+
306444int4 :: TypeInfo
307445int4 = Basic {
308− typoid = Oid 23,
446+ typoid = int4Oid,
309447 typcategory = 'N',
310448 typdelim = ',',
311449 typname = "int4"
312450 }
313451
452+int4Oid :: Oid
453+int4Oid = Oid 23
454+{-# INLINE int4Oid #-}
455+
314456regproc :: TypeInfo
315457regproc = Basic {
316− typoid = Oid 24,
458+ typoid = regprocOid,
317459 typcategory = 'N',
318460 typdelim = ',',
319461 typname = "regproc"
320462 }
321463
464+regprocOid :: Oid
465+regprocOid = Oid 24
466+{-# INLINE regprocOid #-}
467+
322468text :: TypeInfo
323469text = Basic {
324− typoid = Oid 25,
470+ typoid = textOid,
325471 typcategory = 'S',
326472 typdelim = ',',
327473 typname = "text"
328474 }
329475
476+textOid :: Oid
477+textOid = Oid 25
478+{-# INLINE textOid #-}
479+
330480oid :: TypeInfo
331481oid = Basic {
332− typoid = Oid 26,
482+ typoid = oidOid,
333483 typcategory = 'N',
334484 typdelim = ',',
335485 typname = "oid"
336486 }
337487
488+oidOid :: Oid
489+oidOid = Oid 26
490+{-# INLINE oidOid #-}
491+
338492tid :: TypeInfo
339493tid = Basic {
340− typoid = Oid 27,
494+ typoid = tidOid,
341495 typcategory = 'U',
342496 typdelim = ',',
343497 typname = "tid"
344498 }
345499
500+tidOid :: Oid
501+tidOid = Oid 27
502+{-# INLINE tidOid #-}
503+
346504xid :: TypeInfo
347505xid = Basic {
348− typoid = Oid 28,
506+ typoid = xidOid,
349507 typcategory = 'U',
350508 typdelim = ',',
351509 typname = "xid"
352510 }
353511
512+xidOid :: Oid
513+xidOid = Oid 28
514+{-# INLINE xidOid #-}
515+
354516cid :: TypeInfo
355517cid = Basic {
356− typoid = Oid 29,
518+ typoid = cidOid,
357519 typcategory = 'U',
358520 typdelim = ',',
359521 typname = "cid"
360522 }
361523
524+cidOid :: Oid
525+cidOid = Oid 29
526+{-# INLINE cidOid #-}
527+
362528xml :: TypeInfo
363529xml = Basic {
364− typoid = Oid 142,
530+ typoid = xmlOid,
365531 typcategory = 'U',
366532 typdelim = ',',
367533 typname = "xml"
368534 }
369535
536+xmlOid :: Oid
537+xmlOid = Oid 142
538+{-# INLINE xmlOid #-}
539+
370540point :: TypeInfo
371541point = Basic {
372− typoid = Oid 600,
542+ typoid = pointOid,
373543 typcategory = 'G',
374544 typdelim = ',',
375545 typname = "point"
376546 }
377547
548+pointOid :: Oid
549+pointOid = Oid 600
550+{-# INLINE pointOid #-}
551+
378552lseg :: TypeInfo
379553lseg = Basic {
380− typoid = Oid 601,
554+ typoid = lsegOid,
381555 typcategory = 'G',
382556 typdelim = ',',
383557 typname = "lseg"
384558 }
385559
560+lsegOid :: Oid
561+lsegOid = Oid 601
562+{-# INLINE lsegOid #-}
563+
386564path :: TypeInfo
387565path = Basic {
388− typoid = Oid 602,
566+ typoid = pathOid,
389567 typcategory = 'G',
390568 typdelim = ',',
391569 typname = "path"
392570 }
393571
572+pathOid :: Oid
573+pathOid = Oid 602
574+{-# INLINE pathOid #-}
575+
394576box :: TypeInfo
395577box = Basic {
396− typoid = Oid 603,
578+ typoid = boxOid,
397579 typcategory = 'G',
398580 typdelim = ';',
399581 typname = "box"
400582 }
401583
584+boxOid :: Oid
585+boxOid = Oid 603
586+{-# INLINE boxOid #-}
587+
402588polygon :: TypeInfo
403589polygon = Basic {
404− typoid = Oid 604,
590+ typoid = polygonOid,
405591 typcategory = 'G',
406592 typdelim = ',',
407593 typname = "polygon"
408594 }
409595
596+polygonOid :: Oid
597+polygonOid = Oid 604
598+{-# INLINE polygonOid #-}
599+
410600line :: TypeInfo
411601line = Basic {
412− typoid = Oid 628,
602+ typoid = lineOid,
413603 typcategory = 'G',
414604 typdelim = ',',
415605 typname = "line"
416606 }
417607
608+lineOid :: Oid
609+lineOid = Oid 628
610+{-# INLINE lineOid #-}
611+
418612cidr :: TypeInfo
419613cidr = Basic {
420− typoid = Oid 650,
614+ typoid = cidrOid,
421615 typcategory = 'I',
422616 typdelim = ',',
423617 typname = "cidr"
424618 }
425619
620+cidrOid :: Oid
621+cidrOid = Oid 650
622+{-# INLINE cidrOid #-}
623+
426624float4 :: TypeInfo
427625float4 = Basic {
428− typoid = Oid 700,
626+ typoid = float4Oid,
429627 typcategory = 'N',
430628 typdelim = ',',
431629 typname = "float4"
432630 }
433631
632+float4Oid :: Oid
633+float4Oid = Oid 700
634+{-# INLINE float4Oid #-}
635+
434636float8 :: TypeInfo
435637float8 = Basic {
436− typoid = Oid 701,
638+ typoid = float8Oid,
437639 typcategory = 'N',
438640 typdelim = ',',
439641 typname = "float8"
440642 }
441643
644+float8Oid :: Oid
645+float8Oid = Oid 701
646+{-# INLINE float8Oid #-}
647+
442648unknown :: TypeInfo
443649unknown = Basic {
444− typoid = Oid 705,
650+ typoid = unknownOid,
445651 typcategory = 'X',
446652 typdelim = ',',
447653 typname = "unknown"
448654 }
449655
656+unknownOid :: Oid
657+unknownOid = Oid 705
658+{-# INLINE unknownOid #-}
659+
450660circle :: TypeInfo
451661circle = Basic {
452− typoid = Oid 718,
662+ typoid = circleOid,
453663 typcategory = 'G',
454664 typdelim = ',',
455665 typname = "circle"
456666 }
457667
668+circleOid :: Oid
669+circleOid = Oid 718
670+{-# INLINE circleOid #-}
671+
458672money :: TypeInfo
459673money = Basic {
460− typoid = Oid 790,
674+ typoid = moneyOid,
461675 typcategory = 'N',
462676 typdelim = ',',
463677 typname = "money"
464678 }
465679
680+moneyOid :: Oid
681+moneyOid = Oid 790
682+{-# INLINE moneyOid #-}
683+
466684macaddr :: TypeInfo
467685macaddr = Basic {
468− typoid = Oid 829,
686+ typoid = macaddrOid,
469687 typcategory = 'U',
470688 typdelim = ',',
471689 typname = "macaddr"
472690 }
473691
692+macaddrOid :: Oid
693+macaddrOid = Oid 829
694+{-# INLINE macaddrOid #-}
695+
474696inet :: TypeInfo
475697inet = Basic {
476− typoid = Oid 869,
698+ typoid = inetOid,
477699 typcategory = 'I',
478700 typdelim = ',',
479701 typname = "inet"
480702 }
481703
704+inetOid :: Oid
705+inetOid = Oid 869
706+{-# INLINE inetOid #-}
707+
482708bpchar :: TypeInfo
483709bpchar = Basic {
484− typoid = Oid 1042,
710+ typoid = bpcharOid,
485711 typcategory = 'S',
486712 typdelim = ',',
487713 typname = "bpchar"
488714 }
489715
716+bpcharOid :: Oid
717+bpcharOid = Oid 1042
718+{-# INLINE bpcharOid #-}
719+
490720varchar :: TypeInfo
491721varchar = Basic {
492− typoid = Oid 1043,
722+ typoid = varcharOid,
493723 typcategory = 'S',
494724 typdelim = ',',
495725 typname = "varchar"
496726 }
497727
728+varcharOid :: Oid
729+varcharOid = Oid 1043
730+{-# INLINE varcharOid #-}
731+
498732date :: TypeInfo
499733date = Basic {
500− typoid = Oid 1082,
734+ typoid = dateOid,
501735 typcategory = 'D',
502736 typdelim = ',',
503737 typname = "date"
504738 }
505739
740+dateOid :: Oid
741+dateOid = Oid 1082
742+{-# INLINE dateOid #-}
743+
506744time :: TypeInfo
507745time = Basic {
508− typoid = Oid 1083,
746+ typoid = timeOid,
509747 typcategory = 'D',
510748 typdelim = ',',
511749 typname = "time"
512750 }
513751
752+timeOid :: Oid
753+timeOid = Oid 1083
754+{-# INLINE timeOid #-}
755+
514756timestamp :: TypeInfo
515757timestamp = Basic {
516− typoid = Oid 1114,
758+ typoid = timestampOid,
517759 typcategory = 'D',
518760 typdelim = ',',
519761 typname = "timestamp"
520762 }
521763
764+timestampOid :: Oid
765+timestampOid = Oid 1114
766+{-# INLINE timestampOid #-}
767+
522768timestamptz :: TypeInfo
523769timestamptz = Basic {
524− typoid = Oid 1184,
770+ typoid = timestamptzOid,
525771 typcategory = 'D',
526772 typdelim = ',',
527773 typname = "timestamptz"
528774 }
529775
776+timestamptzOid :: Oid
777+timestamptzOid = Oid 1184
778+{-# INLINE timestamptzOid #-}
779+
530780interval :: TypeInfo
531781interval = Basic {
532− typoid = Oid 1186,
782+ typoid = intervalOid,
533783 typcategory = 'T',
534784 typdelim = ',',
535785 typname = "interval"
536786 }
537787
788+intervalOid :: Oid
789+intervalOid = Oid 1186
790+{-# INLINE intervalOid #-}
791+
538792timetz :: TypeInfo
539793timetz = Basic {
540− typoid = Oid 1266,
794+ typoid = timetzOid,
541795 typcategory = 'D',
542796 typdelim = ',',
543797 typname = "timetz"
544798 }
545799
800+timetzOid :: Oid
801+timetzOid = Oid 1266
802+{-# INLINE timetzOid #-}
803+
546804bit :: TypeInfo
547805bit = Basic {
548− typoid = Oid 1560,
806+ typoid = bitOid,
549807 typcategory = 'V',
550808 typdelim = ',',
551809 typname = "bit"
552810 }
553811
812+bitOid :: Oid
813+bitOid = Oid 1560
814+{-# INLINE bitOid #-}
815+
554816varbit :: TypeInfo
555817varbit = Basic {
556− typoid = Oid 1562,
818+ typoid = varbitOid,
557819 typcategory = 'V',
558820 typdelim = ',',
559821 typname = "varbit"
560822 }
561823
824+varbitOid :: Oid
825+varbitOid = Oid 1562
826+{-# INLINE varbitOid #-}
827+
562828numeric :: TypeInfo
563829numeric = Basic {
564− typoid = Oid 1700,
830+ typoid = numericOid,
565831 typcategory = 'N',
566832 typdelim = ',',
567833 typname = "numeric"
568834 }
569835
836+numericOid :: Oid
837+numericOid = Oid 1700
838+{-# INLINE numericOid #-}
839+
570840refcursor :: TypeInfo
571841refcursor = Basic {
572− typoid = Oid 1790,
842+ typoid = refcursorOid,
573843 typcategory = 'U',
574844 typdelim = ',',
575845 typname = "refcursor"
576846 }
577847
848+refcursorOid :: Oid
849+refcursorOid = Oid 1790
850+{-# INLINE refcursorOid #-}
851+
578852record :: TypeInfo
579853record = Basic {
580− typoid = Oid 2249,
854+ typoid = recordOid,
581855 typcategory = 'P',
582856 typdelim = ',',
583857 typname = "record"
584858 }
585859
860+recordOid :: Oid
861+recordOid = Oid 2249
862+{-# INLINE recordOid #-}
863+
586864void :: TypeInfo
587865void = Basic {
588− typoid = Oid 2278,
866+ typoid = voidOid,
589867 typcategory = 'P',
590868 typdelim = ',',
591869 typname = "void"
592870 }
593871
872+voidOid :: Oid
873+voidOid = Oid 2278
874+{-# INLINE voidOid #-}
875+
594876array_record :: TypeInfo
595877array_record = Array {
596− typoid = Oid 2287,
878+ typoid = array_recordOid,
597879 typcategory = 'P',
598880 typdelim = ',',
599881 typname = "_record",
600882 typelem = record
601883 }
602884
885+array_recordOid :: Oid
886+array_recordOid = Oid 2287
887+{-# INLINE array_recordOid #-}
888+
603889regprocedure :: TypeInfo
604890regprocedure = Basic {
605− typoid = Oid 2202,
891+ typoid = regprocedureOid,
606892 typcategory = 'N',
607893 typdelim = ',',
608894 typname = "regprocedure"
609895 }
610896
897+regprocedureOid :: Oid
898+regprocedureOid = Oid 2202
899+{-# INLINE regprocedureOid #-}
900+
611901regoper :: TypeInfo
612902regoper = Basic {
613− typoid = Oid 2203,
903+ typoid = regoperOid,
614904 typcategory = 'N',
615905 typdelim = ',',
616906 typname = "regoper"
617907 }
618908
909+regoperOid :: Oid
910+regoperOid = Oid 2203
911+{-# INLINE regoperOid #-}
912+
619913regoperator :: TypeInfo
620914regoperator = Basic {
621− typoid = Oid 2204,
915+ typoid = regoperatorOid,
622916 typcategory = 'N',
623917 typdelim = ',',
624918 typname = "regoperator"
625919 }
626920
921+regoperatorOid :: Oid
922+regoperatorOid = Oid 2204
923+{-# INLINE regoperatorOid #-}
924+
627925regclass :: TypeInfo
628926regclass = Basic {
629− typoid = Oid 2205,
927+ typoid = regclassOid,
630928 typcategory = 'N',
631929 typdelim = ',',
632930 typname = "regclass"
633931 }
634932
933+regclassOid :: Oid
934+regclassOid = Oid 2205
935+{-# INLINE regclassOid #-}
936+
635937regtype :: TypeInfo
636938regtype = Basic {
637− typoid = Oid 2206,
939+ typoid = regtypeOid,
638940 typcategory = 'N',
639941 typdelim = ',',
640942 typname = "regtype"
641943 }
642944
945+regtypeOid :: Oid
946+regtypeOid = Oid 2206
947+{-# INLINE regtypeOid #-}
948+
643949uuid :: TypeInfo
644950uuid = Basic {
645− typoid = Oid 2950,
951+ typoid = uuidOid,
646952 typcategory = 'U',
647953 typdelim = ',',
648954 typname = "uuid"
649955 }
650956
957+uuidOid :: Oid
958+uuidOid = Oid 2950
959+{-# INLINE uuidOid #-}
960+
651961json :: TypeInfo
652962json = Basic {
653− typoid = Oid 114,
963+ typoid = jsonOid,
654964 typcategory = 'U',
655965 typdelim = ',',
656966 typname = "json"
657967 }
658968
969+jsonOid :: Oid
970+jsonOid = Oid 114
971+{-# INLINE jsonOid #-}
972+
659973jsonb :: TypeInfo
660974jsonb = Basic {
661− typoid = Oid 3802,
975+ typoid = jsonbOid,
662976 typcategory = 'U',
663977 typdelim = ',',
664978 typname = "jsonb"
665979 }
666980
981+jsonbOid :: Oid
982+jsonbOid = Oid 3802
983+{-# INLINE jsonbOid #-}
984+
667985int2vector :: TypeInfo
668986int2vector = Array {
669− typoid = Oid 22,
987+ typoid = int2vectorOid,
670988 typcategory = 'A',
671989 typdelim = ',',
672990 typname = "int2vector",
673991 typelem = int2
674992 }
675993
994+int2vectorOid :: Oid
995+int2vectorOid = Oid 22
996+{-# INLINE int2vectorOid #-}
997+
676998oidvector :: TypeInfo
677999oidvector = Array {
678− typoid = Oid 30,
1000+ typoid = oidvectorOid,
6791001 typcategory = 'A',
6801002 typdelim = ',',
6811003 typname = "oidvector",
6821004 typelem = oid
6831005 }
6841006
1007+oidvectorOid :: Oid
1008+oidvectorOid = Oid 30
1009+{-# INLINE oidvectorOid #-}
1010+
6851011array_xml :: TypeInfo
6861012array_xml = Array {
687− typoid = Oid 143,
1013+ typoid = array_xmlOid,
6881014 typcategory = 'A',
6891015 typdelim = ',',
6901016 typname = "_xml",
6911017 typelem = xml
6921018 }
6931019
1020+array_xmlOid :: Oid
1021+array_xmlOid = Oid 143
1022+{-# INLINE array_xmlOid #-}
1023+
6941024array_json :: TypeInfo
6951025array_json = Array {
696− typoid = Oid 199,
1026+ typoid = array_jsonOid,
6971027 typcategory = 'A',
6981028 typdelim = ',',
6991029 typname = "_json",
7001030 typelem = json
7011031 }
7021032
1033+array_jsonOid :: Oid
1034+array_jsonOid = Oid 199
1035+{-# INLINE array_jsonOid #-}
1036+
7031037array_line :: TypeInfo
7041038array_line = Array {
705− typoid = Oid 629,
1039+ typoid = array_lineOid,
7061040 typcategory = 'A',
7071041 typdelim = ',',
7081042 typname = "_line",
7091043 typelem = line
7101044 }
7111045
1046+array_lineOid :: Oid
1047+array_lineOid = Oid 629
1048+{-# INLINE array_lineOid #-}
1049+
7121050array_cidr :: TypeInfo
7131051array_cidr = Array {
714− typoid = Oid 651,
1052+ typoid = array_cidrOid,
7151053 typcategory = 'A',
7161054 typdelim = ',',
7171055 typname = "_cidr",
7181056 typelem = cidr
7191057 }
7201058
1059+array_cidrOid :: Oid
1060+array_cidrOid = Oid 651
1061+{-# INLINE array_cidrOid #-}
1062+
7211063array_circle :: TypeInfo
7221064array_circle = Array {
723− typoid = Oid 719,
1065+ typoid = array_circleOid,
7241066 typcategory = 'A',
7251067 typdelim = ',',
7261068 typname = "_circle",
7271069 typelem = circle
7281070 }
7291071
1072+array_circleOid :: Oid
1073+array_circleOid = Oid 719
1074+{-# INLINE array_circleOid #-}
1075+
7301076array_money :: TypeInfo
7311077array_money = Array {
732− typoid = Oid 791,
1078+ typoid = array_moneyOid,
7331079 typcategory = 'A',
7341080 typdelim = ',',
7351081 typname = "_money",
7361082 typelem = money
7371083 }
7381084
1085+array_moneyOid :: Oid
1086+array_moneyOid = Oid 791
1087+{-# INLINE array_moneyOid #-}
1088+
7391089array_bool :: TypeInfo
7401090array_bool = Array {
741− typoid = Oid 1000,
1091+ typoid = array_boolOid,
7421092 typcategory = 'A',
7431093 typdelim = ',',
7441094 typname = "_bool",
7451095 typelem = bool
7461096 }
7471097
1098+array_boolOid :: Oid
1099+array_boolOid = Oid 1000
1100+{-# INLINE array_boolOid #-}
1101+
7481102array_bytea :: TypeInfo
7491103array_bytea = Array {
750− typoid = Oid 1001,
1104+ typoid = array_byteaOid,
7511105 typcategory = 'A',
7521106 typdelim = ',',
7531107 typname = "_bytea",
7541108 typelem = bytea
7551109 }
7561110
1111+array_byteaOid :: Oid
1112+array_byteaOid = Oid 1001
1113+{-# INLINE array_byteaOid #-}
1114+
7571115array_char :: TypeInfo
7581116array_char = Array {
759− typoid = Oid 1002,
1117+ typoid = array_charOid,
7601118 typcategory = 'A',
7611119 typdelim = ',',
7621120 typname = "_char",
7631121 typelem = char
7641122 }
7651123
1124+array_charOid :: Oid
1125+array_charOid = Oid 1002
1126+{-# INLINE array_charOid #-}
1127+
7661128array_name :: TypeInfo
7671129array_name = Array {
768− typoid = Oid 1003,
1130+ typoid = array_nameOid,
7691131 typcategory = 'A',
7701132 typdelim = ',',
7711133 typname = "_name",
7721134 typelem = name
7731135 }
7741136
1137+array_nameOid :: Oid
1138+array_nameOid = Oid 1003
1139+{-# INLINE array_nameOid #-}
1140+
7751141array_int2 :: TypeInfo
7761142array_int2 = Array {
777− typoid = Oid 1005,
1143+ typoid = array_int2Oid,
7781144 typcategory = 'A',
7791145 typdelim = ',',
7801146 typname = "_int2",
7811147 typelem = int2
7821148 }
7831149
1150+array_int2Oid :: Oid
1151+array_int2Oid = Oid 1005
1152+{-# INLINE array_int2Oid #-}
1153+
7841154array_int2vector :: TypeInfo
7851155array_int2vector = Array {
786− typoid = Oid 1006,
1156+ typoid = array_int2vectorOid,
7871157 typcategory = 'A',
7881158 typdelim = ',',
7891159 typname = "_int2vector",
7901160 typelem = int2vector
7911161 }
7921162
1163+array_int2vectorOid :: Oid
1164+array_int2vectorOid = Oid 1006
1165+{-# INLINE array_int2vectorOid #-}
1166+
7931167array_int4 :: TypeInfo
7941168array_int4 = Array {
795− typoid = Oid 1007,
1169+ typoid = array_int4Oid,
7961170 typcategory = 'A',
7971171 typdelim = ',',
7981172 typname = "_int4",
7991173 typelem = int4
8001174 }
8011175
1176+array_int4Oid :: Oid
1177+array_int4Oid = Oid 1007
1178+{-# INLINE array_int4Oid #-}
1179+
8021180array_regproc :: TypeInfo
8031181array_regproc = Array {
804− typoid = Oid 1008,
1182+ typoid = array_regprocOid,
8051183 typcategory = 'A',
8061184 typdelim = ',',
8071185 typname = "_regproc",
8081186 typelem = regproc
8091187 }
8101188
1189+array_regprocOid :: Oid
1190+array_regprocOid = Oid 1008
1191+{-# INLINE array_regprocOid #-}
1192+
8111193array_text :: TypeInfo
8121194array_text = Array {
813− typoid = Oid 1009,
1195+ typoid = array_textOid,
8141196 typcategory = 'A',
8151197 typdelim = ',',
8161198 typname = "_text",
8171199 typelem = text
8181200 }
8191201
1202+array_textOid :: Oid
1203+array_textOid = Oid 1009
1204+{-# INLINE array_textOid #-}
1205+
8201206array_tid :: TypeInfo
8211207array_tid = Array {
822− typoid = Oid 1010,
1208+ typoid = array_tidOid,
8231209 typcategory = 'A',
8241210 typdelim = ',',
8251211 typname = "_tid",
8261212 typelem = tid
8271213 }
8281214
1215+array_tidOid :: Oid
1216+array_tidOid = Oid 1010
1217+{-# INLINE array_tidOid #-}
1218+
8291219array_xid :: TypeInfo
8301220array_xid = Array {
831− typoid = Oid 1011,
1221+ typoid = array_xidOid,
8321222 typcategory = 'A',
8331223 typdelim = ',',
8341224 typname = "_xid",
8351225 typelem = xid
8361226 }
8371227
1228+array_xidOid :: Oid
1229+array_xidOid = Oid 1011
1230+{-# INLINE array_xidOid #-}
1231+
8381232array_cid :: TypeInfo
8391233array_cid = Array {
840− typoid = Oid 1012,
1234+ typoid = array_cidOid,
8411235 typcategory = 'A',
8421236 typdelim = ',',
8431237 typname = "_cid",
8441238 typelem = cid
8451239 }
8461240
1241+array_cidOid :: Oid
1242+array_cidOid = Oid 1012
1243+{-# INLINE array_cidOid #-}
1244+
8471245array_oidvector :: TypeInfo
8481246array_oidvector = Array {
849− typoid = Oid 1013,
1247+ typoid = array_oidvectorOid,
8501248 typcategory = 'A',
8511249 typdelim = ',',
8521250 typname = "_oidvector",
8531251 typelem = oidvector
8541252 }
8551253
1254+array_oidvectorOid :: Oid
1255+array_oidvectorOid = Oid 1013
1256+{-# INLINE array_oidvectorOid #-}
1257+
8561258array_bpchar :: TypeInfo
8571259array_bpchar = Array {
858− typoid = Oid 1014,
1260+ typoid = array_bpcharOid,
8591261 typcategory = 'A',
8601262 typdelim = ',',
8611263 typname = "_bpchar",
8621264 typelem = bpchar
8631265 }
8641266
1267+array_bpcharOid :: Oid
1268+array_bpcharOid = Oid 1014
1269+{-# INLINE array_bpcharOid #-}
1270+
8651271array_varchar :: TypeInfo
8661272array_varchar = Array {
867− typoid = Oid 1015,
1273+ typoid = array_varcharOid,
8681274 typcategory = 'A',
8691275 typdelim = ',',
8701276 typname = "_varchar",
8711277 typelem = varchar
8721278 }
8731279
1280+array_varcharOid :: Oid
1281+array_varcharOid = Oid 1015
1282+{-# INLINE array_varcharOid #-}
1283+
8741284array_int8 :: TypeInfo
8751285array_int8 = Array {
876− typoid = Oid 1016,
1286+ typoid = array_int8Oid,
8771287 typcategory = 'A',
8781288 typdelim = ',',
8791289 typname = "_int8",
8801290 typelem = int8
8811291 }
8821292
1293+array_int8Oid :: Oid
1294+array_int8Oid = Oid 1016
1295+{-# INLINE array_int8Oid #-}
1296+
8831297array_point :: TypeInfo
8841298array_point = Array {
885− typoid = Oid 1017,
1299+ typoid = array_pointOid,
8861300 typcategory = 'A',
8871301 typdelim = ',',
8881302 typname = "_point",
8891303 typelem = point
8901304 }
8911305
1306+array_pointOid :: Oid
1307+array_pointOid = Oid 1017
1308+{-# INLINE array_pointOid #-}
1309+
8921310array_lseg :: TypeInfo
8931311array_lseg = Array {
894− typoid = Oid 1018,
1312+ typoid = array_lsegOid,
8951313 typcategory = 'A',
8961314 typdelim = ',',
8971315 typname = "_lseg",
8981316 typelem = lseg
8991317 }
9001318
1319+array_lsegOid :: Oid
1320+array_lsegOid = Oid 1018
1321+{-# INLINE array_lsegOid #-}
1322+
9011323array_path :: TypeInfo
9021324array_path = Array {
903− typoid = Oid 1019,
1325+ typoid = array_pathOid,
9041326 typcategory = 'A',
9051327 typdelim = ',',
9061328 typname = "_path",
9071329 typelem = path
9081330 }
9091331
1332+array_pathOid :: Oid
1333+array_pathOid = Oid 1019
1334+{-# INLINE array_pathOid #-}
1335+
9101336array_box :: TypeInfo
9111337array_box = Array {
912− typoid = Oid 1020,
1338+ typoid = array_boxOid,
9131339 typcategory = 'A',
9141340 typdelim = ';',
9151341 typname = "_box",
9161342 typelem = box
9171343 }
9181344
1345+array_boxOid :: Oid
1346+array_boxOid = Oid 1020
1347+{-# INLINE array_boxOid #-}
1348+
9191349array_float4 :: TypeInfo
9201350array_float4 = Array {
921− typoid = Oid 1021,
1351+ typoid = array_float4Oid,
9221352 typcategory = 'A',
9231353 typdelim = ',',
9241354 typname = "_float4",
9251355 typelem = float4
9261356 }
9271357
1358+array_float4Oid :: Oid
1359+array_float4Oid = Oid 1021
1360+{-# INLINE array_float4Oid #-}
1361+
9281362array_float8 :: TypeInfo
9291363array_float8 = Array {
930− typoid = Oid 1022,
1364+ typoid = array_float8Oid,
9311365 typcategory = 'A',
9321366 typdelim = ',',
9331367 typname = "_float8",
9341368 typelem = float8
9351369 }
9361370
1371+array_float8Oid :: Oid
1372+array_float8Oid = Oid 1022
1373+{-# INLINE array_float8Oid #-}
1374+
9371375array_polygon :: TypeInfo
9381376array_polygon = Array {
939− typoid = Oid 1027,
1377+ typoid = array_polygonOid,
9401378 typcategory = 'A',
9411379 typdelim = ',',
9421380 typname = "_polygon",
9431381 typelem = polygon
9441382 }
9451383
1384+array_polygonOid :: Oid
1385+array_polygonOid = Oid 1027
1386+{-# INLINE array_polygonOid #-}
1387+
9461388array_oid :: TypeInfo
9471389array_oid = Array {
948− typoid = Oid 1028,
1390+ typoid = array_oidOid,
9491391 typcategory = 'A',
9501392 typdelim = ',',
9511393 typname = "_oid",
9521394 typelem = oid
9531395 }
9541396
1397+array_oidOid :: Oid
1398+array_oidOid = Oid 1028
1399+{-# INLINE array_oidOid #-}
1400+
9551401array_macaddr :: TypeInfo
9561402array_macaddr = Array {
957− typoid = Oid 1040,
1403+ typoid = array_macaddrOid,
9581404 typcategory = 'A',
9591405 typdelim = ',',
9601406 typname = "_macaddr",
9611407 typelem = macaddr
9621408 }
9631409
1410+array_macaddrOid :: Oid
1411+array_macaddrOid = Oid 1040
1412+{-# INLINE array_macaddrOid #-}
1413+
9641414array_inet :: TypeInfo
9651415array_inet = Array {
966− typoid = Oid 1041,
1416+ typoid = array_inetOid,
9671417 typcategory = 'A',
9681418 typdelim = ',',
9691419 typname = "_inet",
9701420 typelem = inet
9711421 }
9721422
1423+array_inetOid :: Oid
1424+array_inetOid = Oid 1041
1425+{-# INLINE array_inetOid #-}
1426+
9731427array_timestamp :: TypeInfo
9741428array_timestamp = Array {
975− typoid = Oid 1115,
1429+ typoid = array_timestampOid,
9761430 typcategory = 'A',
9771431 typdelim = ',',
9781432 typname = "_timestamp",
9791433 typelem = timestamp
9801434 }
9811435
1436+array_timestampOid :: Oid
1437+array_timestampOid = Oid 1115
1438+{-# INLINE array_timestampOid #-}
1439+
9821440array_date :: TypeInfo
9831441array_date = Array {
984− typoid = Oid 1182,
1442+ typoid = array_dateOid,
9851443 typcategory = 'A',
9861444 typdelim = ',',
9871445 typname = "_date",
9881446 typelem = date
9891447 }
9901448
1449+array_dateOid :: Oid
1450+array_dateOid = Oid 1182
1451+{-# INLINE array_dateOid #-}
1452+
9911453array_time :: TypeInfo
9921454array_time = Array {
993− typoid = Oid 1183,
1455+ typoid = array_timeOid,
9941456 typcategory = 'A',
9951457 typdelim = ',',
9961458 typname = "_time",
9971459 typelem = time
9981460 }
9991461
1462+array_timeOid :: Oid
1463+array_timeOid = Oid 1183
1464+{-# INLINE array_timeOid #-}
1465+
10001466array_timestamptz :: TypeInfo
10011467array_timestamptz = Array {
1002− typoid = Oid 1185,
1468+ typoid = array_timestamptzOid,
10031469 typcategory = 'A',
10041470 typdelim = ',',
10051471 typname = "_timestamptz",
10061472 typelem = timestamptz
10071473 }
10081474
1475+array_timestamptzOid :: Oid
1476+array_timestamptzOid = Oid 1185
1477+{-# INLINE array_timestamptzOid #-}
1478+
10091479array_interval :: TypeInfo
10101480array_interval = Array {
1011− typoid = Oid 1187,
1481+ typoid = array_intervalOid,
10121482 typcategory = 'A',
10131483 typdelim = ',',
10141484 typname = "_interval",
10151485 typelem = interval
10161486 }
10171487
1488+array_intervalOid :: Oid
1489+array_intervalOid = Oid 1187
1490+{-# INLINE array_intervalOid #-}
1491+
10181492array_numeric :: TypeInfo
10191493array_numeric = Array {
1020− typoid = Oid 1231,
1494+ typoid = array_numericOid,
10211495 typcategory = 'A',
10221496 typdelim = ',',
10231497 typname = "_numeric",
10241498 typelem = numeric
10251499 }
10261500
1501+array_numericOid :: Oid
1502+array_numericOid = Oid 1231
1503+{-# INLINE array_numericOid #-}
1504+
10271505array_timetz :: TypeInfo
10281506array_timetz = Array {
1029− typoid = Oid 1270,
1507+ typoid = array_timetzOid,
10301508 typcategory = 'A',
10311509 typdelim = ',',
10321510 typname = "_timetz",
10331511 typelem = timetz
10341512 }
10351513
1514+array_timetzOid :: Oid
1515+array_timetzOid = Oid 1270
1516+{-# INLINE array_timetzOid #-}
1517+
10361518array_bit :: TypeInfo
10371519array_bit = Array {
1038− typoid = Oid 1561,
1520+ typoid = array_bitOid,
10391521 typcategory = 'A',
10401522 typdelim = ',',
10411523 typname = "_bit",
10421524 typelem = bit
10431525 }
10441526
1527+array_bitOid :: Oid
1528+array_bitOid = Oid 1561
1529+{-# INLINE array_bitOid #-}
1530+
10451531array_varbit :: TypeInfo
10461532array_varbit = Array {
1047− typoid = Oid 1563,
1533+ typoid = array_varbitOid,
10481534 typcategory = 'A',
10491535 typdelim = ',',
10501536 typname = "_varbit",
10511537 typelem = varbit
10521538 }
10531539
1540+array_varbitOid :: Oid
1541+array_varbitOid = Oid 1563
1542+{-# INLINE array_varbitOid #-}
1543+
10541544array_refcursor :: TypeInfo
10551545array_refcursor = Array {
1056− typoid = Oid 2201,
1546+ typoid = array_refcursorOid,
10571547 typcategory = 'A',
10581548 typdelim = ',',
10591549 typname = "_refcursor",
10601550 typelem = refcursor
10611551 }
10621552
1553+array_refcursorOid :: Oid
1554+array_refcursorOid = Oid 2201
1555+{-# INLINE array_refcursorOid #-}
1556+
10631557array_regprocedure :: TypeInfo
10641558array_regprocedure = Array {
1065− typoid = Oid 2207,
1559+ typoid = array_regprocedureOid,
10661560 typcategory = 'A',
10671561 typdelim = ',',
10681562 typname = "_regprocedure",
10691563 typelem = regprocedure
10701564 }
10711565
1566+array_regprocedureOid :: Oid
1567+array_regprocedureOid = Oid 2207
1568+{-# INLINE array_regprocedureOid #-}
1569+
10721570array_regoper :: TypeInfo
10731571array_regoper = Array {
1074− typoid = Oid 2208,
1572+ typoid = array_regoperOid,
10751573 typcategory = 'A',
10761574 typdelim = ',',
10771575 typname = "_regoper",
10781576 typelem = regoper
10791577 }
10801578
1579+array_regoperOid :: Oid
1580+array_regoperOid = Oid 2208
1581+{-# INLINE array_regoperOid #-}
1582+
10811583array_regoperator :: TypeInfo
10821584array_regoperator = Array {
1083− typoid = Oid 2209,
1585+ typoid = array_regoperatorOid,
10841586 typcategory = 'A',
10851587 typdelim = ',',
10861588 typname = "_regoperator",
10871589 typelem = regoperator
10881590 }
10891591
1592+array_regoperatorOid :: Oid
1593+array_regoperatorOid = Oid 2209
1594+{-# INLINE array_regoperatorOid #-}
1595+
10901596array_regclass :: TypeInfo
10911597array_regclass = Array {
1092− typoid = Oid 2210,
1598+ typoid = array_regclassOid,
10931599 typcategory = 'A',
10941600 typdelim = ',',
10951601 typname = "_regclass",
10961602 typelem = regclass
10971603 }
10981604
1605+array_regclassOid :: Oid
1606+array_regclassOid = Oid 2210
1607+{-# INLINE array_regclassOid #-}
1608+
10991609array_regtype :: TypeInfo
11001610array_regtype = Array {
1101− typoid = Oid 2211,
1611+ typoid = array_regtypeOid,
11021612 typcategory = 'A',
11031613 typdelim = ',',
11041614 typname = "_regtype",
11051615 typelem = regtype
11061616 }
11071617
1618+array_regtypeOid :: Oid
1619+array_regtypeOid = Oid 2211
1620+{-# INLINE array_regtypeOid #-}
1621+
11081622array_uuid :: TypeInfo
11091623array_uuid = Array {
1110− typoid = Oid 2951,
1624+ typoid = array_uuidOid,
11111625 typcategory = 'A',
11121626 typdelim = ',',
11131627 typname = "_uuid",
11141628 typelem = uuid
11151629 }
11161630
1631+array_uuidOid :: Oid
1632+array_uuidOid = Oid 2951
1633+{-# INLINE array_uuidOid #-}
1634+
11171635array_jsonb :: TypeInfo
11181636array_jsonb = Array {
1119− typoid = Oid 3807,
1637+ typoid = array_jsonbOid,
11201638 typcategory = 'A',
11211639 typdelim = ',',
11221640 typname = "_jsonb",
11231641 typelem = jsonb
11241642 }
11251643
1644+array_jsonbOid :: Oid
1645+array_jsonbOid = Oid 3807
1646+{-# INLINE array_jsonbOid #-}
1647+
11261648int4range :: TypeInfo
11271649int4range = Range {
1128− typoid = Oid 3904,
1650+ typoid = int4rangeOid,
11291651 typcategory = 'R',
11301652 typdelim = ',',
11311653 typname = "int4range",
11321654 rngsubtype = int4
11331655 }
11341656
1657+int4rangeOid :: Oid
1658+int4rangeOid = Oid 3904
1659+{-# INLINE int4rangeOid #-}
1660+
11351661_int4range :: TypeInfo
11361662_int4range = Array {
1137− typoid = Oid 3905,
1663+ typoid = _int4rangeOid,
11381664 typcategory = 'A',
11391665 typdelim = ',',
11401666 typname = "_int4range",
11411667 typelem = int4range
11421668 }
11431669
1670+_int4rangeOid :: Oid
1671+_int4rangeOid = Oid 3905
1672+{-# INLINE _int4rangeOid #-}
1673+
11441674numrange :: TypeInfo
11451675numrange = Range {
1146− typoid = Oid 3906,
1676+ typoid = numrangeOid,
11471677 typcategory = 'R',
11481678 typdelim = ',',
11491679 typname = "numrange",
11501680 rngsubtype = numeric
11511681 }
11521682
1683+numrangeOid :: Oid
1684+numrangeOid = Oid 3906
1685+{-# INLINE numrangeOid #-}
1686+
11531687_numrange :: TypeInfo
11541688_numrange = Array {
1155− typoid = Oid 3907,
1689+ typoid = _numrangeOid,
11561690 typcategory = 'A',
11571691 typdelim = ',',
11581692 typname = "_numrange",
11591693 typelem = numrange
11601694 }
11611695
1696+_numrangeOid :: Oid
1697+_numrangeOid = Oid 3907
1698+{-# INLINE _numrangeOid #-}
1699+
11621700tsrange :: TypeInfo
11631701tsrange = Range {
1164− typoid = Oid 3908,
1702+ typoid = tsrangeOid,
11651703 typcategory = 'R',
11661704 typdelim = ',',
11671705 typname = "tsrange",
11681706 rngsubtype = timestamp
11691707 }
11701708
1709+tsrangeOid :: Oid
1710+tsrangeOid = Oid 3908
1711+{-# INLINE tsrangeOid #-}
1712+
11711713_tsrange :: TypeInfo
11721714_tsrange = Array {
1173− typoid = Oid 3909,
1715+ typoid = _tsrangeOid,
11741716 typcategory = 'A',
11751717 typdelim = ',',
11761718 typname = "_tsrange",
11771719 typelem = tsrange
11781720 }
11791721
1722+_tsrangeOid :: Oid
1723+_tsrangeOid = Oid 3909
1724+{-# INLINE _tsrangeOid #-}
1725+
11801726tstzrange :: TypeInfo
11811727tstzrange = Range {
1182− typoid = Oid 3910,
1728+ typoid = tstzrangeOid,
11831729 typcategory = 'R',
11841730 typdelim = ',',
11851731 typname = "tstzrange",
11861732 rngsubtype = timestamptz
11871733 }
11881734
1735+tstzrangeOid :: Oid
1736+tstzrangeOid = Oid 3910
1737+{-# INLINE tstzrangeOid #-}
1738+
11891739_tstzrange :: TypeInfo
11901740_tstzrange = Array {
1191− typoid = Oid 3911,
1741+ typoid = _tstzrangeOid,
11921742 typcategory = 'A',
11931743 typdelim = ',',
11941744 typname = "_tstzrange",
11951745 typelem = tstzrange
11961746 }
11971747
1748+_tstzrangeOid :: Oid
1749+_tstzrangeOid = Oid 3911
1750+{-# INLINE _tstzrangeOid #-}
1751+
11981752daterange :: TypeInfo
11991753daterange = Range {
1200− typoid = Oid 3912,
1754+ typoid = daterangeOid,
12011755 typcategory = 'R',
12021756 typdelim = ',',
12031757 typname = "daterange",
12041758 rngsubtype = date
12051759 }
12061760
1761+daterangeOid :: Oid
1762+daterangeOid = Oid 3912
1763+{-# INLINE daterangeOid #-}
1764+
12071765_daterange :: TypeInfo
12081766_daterange = Array {
1209− typoid = Oid 3913,
1767+ typoid = _daterangeOid,
12101768 typcategory = 'A',
12111769 typdelim = ',',
12121770 typname = "_daterange",
12131771 typelem = daterange
12141772 }
12151773
1774+_daterangeOid :: Oid
1775+_daterangeOid = Oid 3913
1776+{-# INLINE _daterangeOid #-}
1777+
12161778int8range :: TypeInfo
12171779int8range = Range {
1218− typoid = Oid 3926,
1780+ typoid = int8rangeOid,
12191781 typcategory = 'R',
12201782 typdelim = ',',
12211783 typname = "int8range",
12221784 rngsubtype = int8
12231785 }
12241786
1787+int8rangeOid :: Oid
1788+int8rangeOid = Oid 3926
1789+{-# INLINE int8rangeOid #-}
1790+
12251791_int8range :: TypeInfo
12261792_int8range = Array {
1227− typoid = Oid 3927,
1793+ typoid = _int8rangeOid,
12281794 typcategory = 'A',
12291795 typdelim = ',',
12301796 typname = "_int8range",
12311797 typelem = int8range
12321798 }
1799+
1800+_int8rangeOid :: Oid
1801+_int8rangeOid = Oid 3927
1802+{-# INLINE _int8rangeOid #-}
src/Database/PostgreSQL/Simple/Types.hs+9−25
@@ -1,4 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
22
33------------------------------------------------------------------------------
44-- |
@@ -33,13 +33,16 @@ module Database.PostgreSQL.Simple.Types
3333import Control.Arrow (first)
3434import Data.ByteString (ByteString)
3535import Data.Hashable (Hashable(hashWithSalt))
36+import Data.Foldable (toList)
3637import Data.Monoid (Monoid(..))
38+import Data.Semigroup
3739import Data.String (IsString(..))
3840import Data.Typeable (Typeable)
3941import Data.ByteString.Builder ( stringUtf8 )
4042import qualified Data.ByteString as B
4143import Data.Text (Text)
4244import qualified Data.Text as T
45+import Data.Tuple.Only (Only(..))
4346import Database.PostgreSQL.LibPQ (Oid(..))
4447import Database.PostgreSQL.Simple.Compat (toByteString)
4548
@@ -47,10 +50,6 @@ import Database.PostgreSQL.Simple.Compat (toByteString)
4750data Null = Null
4851 deriving (Read, Show, Typeable)
4952
50−instance Eq Null where
51− _ == _ = False
52− _ /= _ = False
53−
5453-- | A placeholder for the PostgreSQL @DEFAULT@ value.
5554data Default = Default
5655 deriving (Read, Show, Typeable)
@@ -87,28 +86,13 @@ instance Read Query where
8786instance IsString Query where
8887 fromString = Query . toByteString . stringUtf8
8988
89+instance Semigroup Query where
90+ Query a <> Query b = Query (B.append a b)
91+ {-# INLINE (<>) #-}
92+ sconcat xs = Query (B.concat $ map fromQuery $ toList xs)
93+
9094instance Monoid Query where
9195 mempty = Query B.empty
92− mappend (Query a) (Query b) = Query (B.append a b)
93− {-# INLINE mappend #-}
94− mconcat xs = Query (B.concat (map fromQuery xs))
95−
96−-- | A single-value \"collection\".
97−--
98−-- This is useful if you need to supply a single parameter to a SQL
99−-- query, or extract a single column from a SQL result.
100−--
101−-- Parameter example:
102−--
103−-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@
104−--
105−-- Result example:
106−--
107−-- @xs <- query_ c \"select id from users\"
108−--forM_ xs $ \\('Only' id) -> {- ... -}@
109−newtype Only a = Only {
110− fromOnly :: a
111− } deriving (Eq, Ord, Read, Show, Typeable, Functor)
11296
11397-- | Wrap a list of values for use in an @IN@ clause. Replaces a
11498-- single \"@?@\" character with a parenthesized list of rendered
src/Database/PostgreSQL/Simple/Vector.hsnew file+45
@@ -0,0 +1,45 @@
1+-- | 'query' variants returning 'V.Vector'.
2+module Database.PostgreSQL.Simple.Vector where
3+
4+import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)
5+import Database.PostgreSQL.Simple.FromRow (FromRow(..))
6+import Database.PostgreSQL.Simple.ToRow (ToRow(..))
7+import Database.PostgreSQL.Simple.Internal (RowParser, exec)
8+import Database.PostgreSQL.Simple.Internal.PQResultUtils
9+import Database.PostgreSQL.Simple.Types ( Query (..) )
10+
11+import qualified Data.Vector as V
12+
13+-- | Perform a @SELECT@ or other SQL query that is expected to return
14+-- results. All results are retrieved and converted before this
15+-- function returns.
16+query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO (V.Vector r)
17+query = queryWith fromRow
18+
19+-- | A version of 'query' that does not perform query substitution.
20+query_ :: (FromRow r) => Connection -> Query -> IO (V.Vector r)
21+query_ = queryWith_ fromRow
22+
23+-- | A version of 'query' taking parser as argument
24+queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO (V.Vector r)
25+queryWith parser conn template qs = do
26+ result <- exec conn =<< formatQuery conn template qs
27+ finishQueryWithV parser conn template result
28+
29+-- | A version of 'query_' taking parser as argument
30+queryWith_ :: RowParser r -> Connection -> Query -> IO (V.Vector r)
31+queryWith_ parser conn q@(Query que) = do
32+ result <- exec conn que
33+ finishQueryWithV parser conn q result
34+
35+-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
36+-- query that accepts multi-row input and is expected to return results.
37+returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO (V.Vector r)
38+returning = returningWith fromRow
39+
40+-- | A version of 'returning' taking parser as argument
41+returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO (V.Vector r)
42+returningWith _ _ _ [] = return V.empty
43+returningWith parser conn q qs = do
44+ result <- exec conn =<< formatMany conn q qs
45+ finishQueryWithV parser conn q result
src/Database/PostgreSQL/Simple/Vector/Unboxed.hsnew file+44
@@ -0,0 +1,44 @@
1+module Database.PostgreSQL.Simple.Vector.Unboxed where
2+
3+import Database.PostgreSQL.Simple (Connection, formatQuery, formatMany)
4+import Database.PostgreSQL.Simple.FromRow (FromRow(..))
5+import Database.PostgreSQL.Simple.ToRow (ToRow(..))
6+import Database.PostgreSQL.Simple.Internal (RowParser, exec)
7+import Database.PostgreSQL.Simple.Internal.PQResultUtils
8+import Database.PostgreSQL.Simple.Types ( Query (..) )
9+
10+import qualified Data.Vector.Unboxed as VU
11+
12+-- | Perform a @SELECT@ or other SQL query that is expected to return
13+-- results. All results are retrieved and converted before this
14+-- function returns.
15+query :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> q -> IO (VU.Vector r)
16+query = queryWith fromRow
17+
18+-- | A version of 'query' that does not perform query substitution.
19+query_ :: (FromRow r, VU.Unbox r) => Connection -> Query -> IO (VU.Vector r)
20+query_ = queryWith_ fromRow
21+
22+-- | A version of 'query' taking parser as argument
23+queryWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> q -> IO (VU.Vector r)
24+queryWith parser conn template qs = do
25+ result <- exec conn =<< formatQuery conn template qs
26+ finishQueryWithVU parser conn template result
27+
28+-- | A version of 'query_' taking parser as argument
29+queryWith_ :: VU.Unbox r => RowParser r -> Connection -> Query -> IO (VU.Vector r)
30+queryWith_ parser conn q@(Query que) = do
31+ result <- exec conn que
32+ finishQueryWithVU parser conn q result
33+
34+-- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL
35+-- query that accepts multi-row input and is expected to return results.
36+returning :: (ToRow q, FromRow r, VU.Unbox r) => Connection -> Query -> [q] -> IO (VU.Vector r)
37+returning = returningWith fromRow
38+
39+-- | A version of 'returning' taking parser as argument
40+returningWith :: (ToRow q, VU.Unbox r) => RowParser r -> Connection -> Query -> [q] -> IO (VU.Vector r)
41+returningWith _ _ _ [] = return VU.empty
42+returningWith parser conn q qs = do
43+ result <- exec conn =<< formatMany conn q qs
44+ finishQueryWithVU parser conn q result
test/Exception.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Exception (testExceptions) where
6+
7+import Database.PostgreSQL.Simple
8+import Test.Tasty.HUnit (Assertion, assertBool)
9+import Common (TestEnv)
10+import Control.Exception (Exception (..), SomeException)
11+import Data.Maybe (isJust)
12+import Data.Either (isLeft)
13+import Control.Exception (throwIO, try)
14+
15+testExceptions :: TestEnv -> Assertion
16+testExceptions _ = do
17+ let sqlError = SqlError
18+ { sqlState = ""
19+ , sqlExecStatus = FatalError
20+ , sqlErrorMsg = ""
21+ , sqlErrorDetail = ""
22+ , sqlErrorHint = ""
23+ }
24+ let sqlEx :: SomeException = toException sqlError
25+ assertBool "SqlError is SomePostgreSqlException" $ isJust (fromException sqlEx :: Maybe SomePostgreSqlException)
26+ assertBool "SqlError is SqlError" $ isJust (fromException sqlEx :: Maybe SqlError)
27+ eSqlError :: Either SqlError () <- try $ throwIO sqlEx
28+ assertBool "Can catch SqlError" $ isLeft eSqlError
29+ eSqlPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO sqlEx
30+ assertBool "Can catch SomePostgreSqlException from SqlError" $ isLeft eSqlPostgreSqlEx
31+
32+ let formatError = FormatError
33+ { fmtMessage = ""
34+ , fmtQuery = ""
35+ , fmtParams = []
36+ }
37+ let formatEx :: SomeException = toException formatError
38+ assertBool "FormatError is SomePostgreSqlException" $ isJust (fromException formatEx :: Maybe SomePostgreSqlException)
39+ assertBool "FormatError is FormatError" $ isJust (fromException formatEx :: Maybe FormatError)
40+ eFormatError :: Either FormatError () <- try $ throwIO formatEx
41+ assertBool "Can catch FormatError" $ isLeft eFormatError
42+ eFormatPostreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO formatEx
43+ assertBool "Can catch SomePostgreSqlException from FormatError" $ isLeft eFormatPostreSqlEx
44+
45+ let queryError = QueryError
46+ { qeMessage = ""
47+ , qeQuery = ""
48+ }
49+ let queryEx :: SomeException = toException queryError
50+ assertBool "QueryError is SomePostgreSqlException" $ isJust (fromException queryEx :: Maybe SomePostgreSqlException)
51+ assertBool "QueryError is QueryError" $ isJust (fromException queryEx :: Maybe QueryError)
52+ eQueryError :: Either QueryError () <- try $ throwIO queryEx
53+ assertBool "Can catch QueryError" $ isLeft eQueryError
54+ eQueryPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO queryEx
55+ assertBool "Can catch SomePostgreSqlException from QueryError" $ isLeft eQueryPostgreSqlEx
56+
57+ let resultError = Incompatible
58+ { errSQLType = ""
59+ , errSQLTableOid = Nothing
60+ , errSQLField = ""
61+ , errHaskellType = ""
62+ , errMessage = ""
63+ }
64+ let resultEx :: SomeException = toException resultError
65+ assertBool "ResultError is SomePostgreSqlException" $ isJust (fromException resultEx :: Maybe SomePostgreSqlException)
66+ assertBool "ResultError is ResultError" $ isJust (fromException resultEx :: Maybe ResultError)
67+ eResultEx :: Either ResultError () <- try $ throwIO resultEx
68+ assertBool "Can catch ResultError" $ isLeft eResultEx
69+ eResultPostgreSqlEx :: Either SomePostgreSqlException () <- try $ throwIO resultEx
70+ assertBool "Can catch SomePostgreSqlException from ResultError" $ isLeft eResultPostgreSqlEx
test/Inspection.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+{-# OPTIONS_GHC -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures #-}
4+-- {-# OPTIONS_GHC -dsuppress-uniques #-}
5+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-}
6+module Main where
7+
8+import Test.Inspection
9+import Test.Tasty
10+import Test.Tasty.HUnit
11+
12+import qualified Database.PostgreSQL.LibPQ as PQ
13+import Database.PostgreSQL.Simple.FromField
14+import Database.PostgreSQL.Simple.TypeInfo as TI
15+import Database.PostgreSQL.Simple.TypeInfo.Macro
16+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
17+
18+-------------------------------------------------------------------------------
19+-- Inspection tests
20+-------------------------------------------------------------------------------
21+
22+-- # doesn't work :(
23+#define TH_MKCOMPATS3(a,b,c) $(mkCompats [TI.a,TI.b,TI.c])
24+#define IN_MKCOMPATS3(a,b,c) (eq TI.a \/ eq TI.b \/ eq TI.c)
25+
26+#define TH_INLINETYPOID(n) eq $(inlineTypoid TI.n)
27+#define IN_INLINETYPOID(n) eq TI.n
28+
29+-- eta-expansion is required
30+lhs01, rhs01 :: PQ.Oid -> Bool
31+lhs01 = TH_MKCOMPATS3(name,text,char)
32+rhs01 = IN_MKCOMPATS3(nameOid,textOid,charOid)
33+
34+lhs02, rhs02 :: PQ.Oid -> Bool
35+lhs02 = TH_INLINETYPOID(name)
36+rhs02 = IN_INLINETYPOID(nameOid)
37+
38+eq :: PQ.Oid -> PQ.Oid -> Bool
39+eq = (==)
40+{-# INLINE eq #-}
41+
42+infixr 2 \/
43+(\/) :: (PQ.Oid -> Bool)
44+ -> (PQ.Oid -> Bool)
45+ -> (PQ.Oid -> Bool)
46+f \/ g = \x -> f x || g x
47+{-# INLINE (\/) #-}
48+
49+inspectionTests :: TestTree
50+inspectionTests = testGroup "inspection"
51+ [ testCase "mkCompats" $
52+ assertSuccess $(inspectTest $ 'lhs01 === 'rhs01)
53+
54+ -- byteaOid isn't inlined?
55+ , testCase "inlineTypoid" $
56+#if __GLASGOW_HASKELL__ >= 808
57+ assertSuccess
58+#else
59+ assertFailure'
60+#endif
61+ $(inspectTest $ 'lhs02 ==- 'rhs02)
62+ ]
63+
64+assertSuccess :: Result -> IO ()
65+assertSuccess (Success _) = return ()
66+assertSuccess (Failure err) = assertFailure err
67+
68+assertFailure' :: Result -> IO ()
69+assertFailure' (Success err) = assertFailure err
70+assertFailure' (Failure _) = return ()
71+
72+-------------------------------------------------------------------------------
73+-- Main
74+-------------------------------------------------------------------------------
75+
76+main :: IO ()
77+main = defaultMain $ testGroup "tests"
78+ [ inspectionTests
79+ ]
test/Interval.hsnew file+176
@@ -0,0 +1,176 @@
1+{-# LANGUAGE QuasiQuotes #-}
2+
3+{-
4+
5+Testing strategies:
6+
7+fromString . toString == id ** Todo?
8+
9+toString . fromString == almost id ** Todo?
10+
11+postgresql -> haskell -> postgresql * Done
12+
13+haskell -> postgresql -> haskell ** Todo?
14+
15+But still, what we really want to establish is that the two values
16+correspond; for example, a conversion that consistently added hour
17+when printed to a string and subtracted an hour when parsed from string
18+would still pass these tests.
19+
20+
21+Right now, we are checking that 1400+ timestamps in the range of 1860 to
22+2060 round trip from postgresql to haskell and back in 5 different timezones.
23+In addition to UTC, the four timezones were selected so that 2 have a positive
24+offset, and 2 have a negative offset, and that 2 have an offset of a
25+whole number of hours, while the other two do not.
26+
27+It may be worth adding a few more timezones to ensure better test coverage.
28+
29+We are checking a handful of selected timestamps to ensure we hit
30+various corner-cases in the code, in addition to 1400 timestamps randomly
31+generated with granularity of seconds down to microseconds in powers of ten.
32+
33+-}
34+
35+module Interval (testInterval) where
36+
37+import Common
38+import Control.Monad(forM_, replicateM_)
39+import Data.Time.Compat
40+import Data.Time.LocalTime.Compat (CalendarDiffTime(..))
41+import Data.ByteString(ByteString)
42+import Database.PostgreSQL.Simple.SqlQQ
43+
44+data IntervalTestCase = IntervalTestCase
45+ { label :: String
46+ , inputMonths :: Integer
47+ , inputSeconds :: NominalDiffTime
48+ , asText :: String
49+ }
50+ deriving (Eq, Show)
51+
52+testInterval :: TestEnv -> Assertion
53+testInterval env@TestEnv{..} = do
54+
55+ initializeTable env
56+
57+ let milliseconds = 0.001
58+ seconds = 1
59+ minutes = 60 * seconds
60+ hours = 60 * minutes
61+ days = 24 * hours
62+ weeks = 7 * days
63+ months = 1
64+ years = 12 * months
65+
66+ mapM (checkRoundTrip env)
67+ [ IntervalTestCase
68+ { label = "zero"
69+ , inputMonths = 0
70+ , inputSeconds = 0
71+ , asText = "PT0"
72+ }
73+ , IntervalTestCase
74+ { label = "1 year"
75+ , inputMonths = 1 * years
76+ , inputSeconds = 0
77+ , asText = "P1Y"
78+ }
79+ , IntervalTestCase
80+ { label = "2 months"
81+ , inputMonths = 2 * months
82+ , inputSeconds = 0
83+ , asText = "P2M"
84+ }
85+ , IntervalTestCase
86+ { label = "3 weeks"
87+ , inputMonths = 0
88+ , inputSeconds = 3 * weeks
89+ , asText = "P3W"
90+ }
91+ , IntervalTestCase
92+ { label = "4 days"
93+ , inputMonths = 0
94+ , inputSeconds = 4 * days
95+ , asText = "P4D"
96+ }
97+ , IntervalTestCase
98+ { label = "5 hours"
99+ , inputMonths = 0
100+ , inputSeconds = 5 * hours
101+ , asText = "PT5H"
102+ }
103+ , IntervalTestCase
104+ { label = "6 minutes"
105+ , inputMonths = 0
106+ , inputSeconds = 6 * minutes
107+ , asText = "PT6M"
108+ }
109+ , IntervalTestCase
110+ { label = "7 seconds"
111+ , inputMonths = 0
112+ , inputSeconds = 7 * seconds
113+ , asText = "PT7S"
114+ }
115+ , IntervalTestCase
116+ { label = "8 milliseconds"
117+ , inputMonths = 0
118+ , inputSeconds = 8 * milliseconds
119+ , asText = "PT0.008S"
120+ }
121+ , IntervalTestCase
122+ { label = "combination of intervals (day-size or bigger)"
123+ , inputMonths = 2 * years + 4 * months
124+ , inputSeconds = 3 * weeks + 5 * days
125+ , asText = "P2Y4M3W5D"
126+ }
127+ , IntervalTestCase
128+ { label = "combination of intervals (smaller than day-size)"
129+ , inputMonths = 0
130+ , inputSeconds = 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
131+ , asText = "PT18H56M23.563S"
132+ }
133+ , IntervalTestCase
134+ { label = "full combination of intervals"
135+ , inputMonths = 2 * years + 4 * months
136+ , inputSeconds = 3 * weeks + 5 * days + 18 * hours + 56 * minutes + 23 * seconds + 563 * milliseconds
137+ , asText = "P2Y4M3W5DT18H56M23.563S"
138+ }
139+ ]
140+
141+ return ()
142+
143+initializeTable :: TestEnv -> IO ()
144+initializeTable TestEnv{..} = withTransaction conn $ do
145+ execute_ conn
146+ [sql| CREATE TEMPORARY TABLE testinterval
147+ ( id serial, sample interval, PRIMARY KEY(id) ) |]
148+
149+ return ()
150+
151+checkRoundTrip :: TestEnv -> IntervalTestCase -> IO ()
152+checkRoundTrip TestEnv{..} IntervalTestCase{..} = do
153+
154+ let input = CalendarDiffTime
155+ { ctMonths = inputMonths
156+ , ctTime = inputSeconds
157+ }
158+
159+ [(returnedId :: Int, output :: CalendarDiffTime)] <- query conn [sql|
160+ INSERT INTO testinterval (sample)
161+ VALUES (?)
162+ RETURNING id, sample
163+ |] (Only input)
164+
165+ assertBool ("CalendarDiffTime did not round-trip from Haskell to SQL and back (" ++ label ++ ")") $
166+ output == input
167+
168+ [(Only isExpectedIso)] <- query conn [sql|
169+ SELECT sample = (?)::interval
170+ FROM testinterval
171+ WHERE id = ?
172+ |] (asText, returnedId)
173+
174+ assertBool ("CalendarDiffTime inserted did not match ISO8601 equivalent \"" ++ asText ++ "\". (" ++ label ++ ")")
175+ isExpectedIso
176+
test/Main.hs+194−31
@@ -3,26 +3,42 @@
33{-# LANGUAGE DeriveDataTypeable #-}
44{-# LANGUAGE DoAndIfThenElse #-}
55{-# LANGUAGE ScopedTypeVariables #-}
6+#if __GLASGOW_HASKELL__ >= 806
7+{-# LANGUAGE DerivingStrategies #-}
8+{-# LANGUAGE DerivingVia #-}
9+{-# LANGUAGE DeriveAnyClass #-}
10+#endif
11+module Main (main) where
12+
613import Common
14+import Database.PostgreSQL.Simple.Copy
15+import Database.PostgreSQL.Simple.ToField (ToField)
716import Database.PostgreSQL.Simple.FromField (FromField)
8−import Database.PostgreSQL.Simple.Types(Query(..),Values(..))
917import Database.PostgreSQL.Simple.HStore
10−import Database.PostgreSQL.Simple.Copy
18+import Database.PostgreSQL.Simple.Newtypes
19+import Database.PostgreSQL.Simple.Internal (breakOnSingleQuestionMark)
20+import Database.PostgreSQL.Simple.Types(Query(..),Values(..), PGArray(..))
1121import qualified Database.PostgreSQL.Simple.Transaction as ST
1222
1323import Control.Applicative
1424import Control.Exception as E
1525import Control.Monad
1626import Data.Char
17−import Data.List (sort)
27+import Data.Foldable (toList)
28+import Data.List (concat, sort)
1829import Data.IORef
30+import Data.Monoid ((<>))
31+import Data.String (fromString)
1932import Data.Typeable
2033import GHC.Generics (Generic)
2134
2235import Data.Aeson
2336import Data.ByteString (ByteString)
2437import qualified Data.ByteString as B
38+import qualified Data.ByteString.Char8 as BS8
2539import qualified Data.ByteString.Lazy.Char8 as BL
40+import Data.CaseInsensitive (CI)
41+import qualified Data.CaseInsensitive as CI
2642import Data.Map (Map)
2743import qualified Data.Map as Map
2844import Data.Text(Text)
@@ -30,37 +46,46 @@ import qualified Data.Text.Encoding as T
3046import qualified Data.Vector as V
3147import System.FilePath
3248import System.Timeout(timeout)
33−import Data.Time(getCurrentTime, diffUTCTime)
49+import Data.Time.Compat (getCurrentTime, diffUTCTime)
50+import System.Environment (getEnvironment)
3451
3552import Test.Tasty
3653import Test.Tasty.Golden
3754import Notify
3855import Serializable
3956import Time
57+import Interval
58+import Exception (testExceptions)
4059
4160tests :: TestEnv -> TestTree
4261tests env = testGroup "tests"
4362 $ map ($ env)
4463 [ testBytea
45− , testCase "ExecuteMany" . testExecuteMany
46− , testCase "Fold" . testFold
47− , testCase "Notify" . testNotify
48− , testCase "Serializable" . testSerializable
49− , testCase "Time" . testTime
50− , testCase "Array" . testArray
51− , testCase "Array of nullables" . testNullableArray
52− , testCase "HStore" . testHStore
53− , testCase "JSON" . testJSON
54− , testCase "Savepoint" . testSavepoint
55− , testCase "Unicode" . testUnicode
56− , testCase "Values" . testValues
57− , testCase "Copy" . testCopy
64+ , testCase "ExecuteMany" . testExecuteMany
65+ , testCase "Fold" . testFold
66+ , testCase "Notify" . testNotify
67+ , testCase "Serializable" . testSerializable
68+ , testCase "Time" . testTime
69+ , testCase "Interval" . testInterval
70+ , testCase "Array" . testArray
71+ , testCase "Array of nullables" . testNullableArray
72+ , testCase "HStore" . testHStore
73+ , testCase "citext" . testCIText
74+ , testCase "JSON" . testJSON
75+ , testCase "Aeson newtype" . testAeson
76+ , testCase "DerivingVia" . testDerivingVia
77+ , testCase "Question mark escape" . testQM
78+ , testCase "Savepoint" . testSavepoint
79+ , testCase "Unicode" . testUnicode
80+ , testCase "Values" . testValues
81+ , testCase "Copy" . testCopy
5882 , testCopyFailures
59− , testCase "Double" . testDouble
60− , testCase "1-ary generic" . testGeneric1
61− , testCase "2-ary generic" . testGeneric2
62− , testCase "3-ary generic" . testGeneric3
63− , testCase "Timeout" . testTimeout
83+ , testCase "Double" . testDouble
84+ , testCase "1-ary generic" . testGeneric1
85+ , testCase "2-ary generic" . testGeneric2
86+ , testCase "3-ary generic" . testGeneric3
87+ , testCase "Timeout" . testTimeout
88+ , testCase "Exceptions" . testExceptions
6489 ]
6590
6691testBytea :: TestEnv -> TestTree
@@ -114,7 +139,7 @@ testFold TestEnv{..} = do
114139 xs <- readIORef ref
115140 writeIORef ref $! (a,b):xs
116141 xs <- readIORef ref
117− reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]]
142+ reverse xs @?= [(a,b) | b <- [1..50], a <- [1..100]]
118143
119144 -- Make sure fold propagates our exception.
120145 ref <- newIORef []
@@ -203,6 +228,19 @@ testHStore TestEnv{..} = do
203228 m' <- query conn "SELECT ?::hstore" m
204229 [m] @?= m'
205230
231+testCIText :: TestEnv -> Assertion
232+testCIText TestEnv{..} = do
233+ execute_ conn "CREATE EXTENSION IF NOT EXISTS citext"
234+ roundTrip (CI.mk "")
235+ roundTrip (CI.mk "UPPERCASE")
236+ roundTrip (CI.mk "lowercase")
237+ where
238+ roundTrip :: (CI Text) -> Assertion
239+ roundTrip cit = do
240+ let toPostgres = Only cit
241+ fromPostgres <- query conn "SELECT ?::citext" toPostgres
242+ [toPostgres] @?= fromPostgres
243+
206244testJSON :: TestEnv -> Assertion
207245testJSON TestEnv{..} = do
208246 roundTrip (Map.fromList [] :: Map Text Text)
@@ -218,6 +256,90 @@ testJSON TestEnv{..} = do
218256 js' <- query conn "SELECT ?::json" js
219257 [js] @?= js'
220258
259+testAeson :: TestEnv -> Assertion
260+testAeson TestEnv{..} = do
261+ roundTrip (Map.fromList [] :: Map Text Text)
262+ roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text)
263+ roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text)
264+ roundTrip (V.fromList [1,2,3,4,5::Int])
265+ roundTrip ("foo" :: Text)
266+ roundTrip (42 :: Int)
267+ where
268+ roundTrip :: (Eq a, Show a, Typeable a, ToJSON a, FromJSON a)=> a -> Assertion
269+ roundTrip x = do
270+ y <- query conn "SELECT ?::json" (Only (Aeson x))
271+ [Only (Aeson x)] @?= y
272+
273+testDerivingVia :: TestEnv -> Assertion
274+testDerivingVia TestEnv{..} = do
275+#if __GLASGOW_HASKELL__ <806
276+ return ()
277+#else
278+ roundTrip $ DerivingVia1 42 "Meaning of Life"
279+ where
280+ roundTrip :: (Eq a, Show a, Typeable a, ToField a, FromField a)=> a -> Assertion
281+ roundTrip x = do
282+ y <- query conn "SELECT ?::json" (Only x)
283+ [Only x] @?= y
284+
285+data DerivingVia1 = DerivingVia1 Int String
286+ deriving stock (Eq, Show, Generic)
287+ deriving anyclass (FromJSON, ToJSON)
288+ deriving (ToField, FromField) via Aeson DerivingVia1
289+
290+#endif
291+
292+
293+testQM :: TestEnv -> Assertion
294+testQM TestEnv{..} = do
295+ -- Just test on a single string
296+ let testQuery' b = "testing for ?" <> b <> " and making sure "
297+ testQueryDoubleQM = testQuery' "?"
298+ testQueryRest = "? is substituted"
299+ testQuery = fromString $ testQueryDoubleQM <> testQueryRest
300+ -- expect the entire first part with double QMs replaced with literal '?'
301+ expected = (fromString $ testQuery' "", fromString testQueryRest)
302+ tried = breakOnSingleQuestionMark testQuery
303+ errMsg = concat
304+ [ "Failed to break on single question mark exclusively:\n"
305+ , "expected: ", show expected
306+ , "result: ", show tried
307+ ]
308+ assertBool errMsg $ tried == expected
309+
310+ -- Let's also test the question mark operators in action
311+ -- ? -> Does the string exist as a top-level key within the JSON value?
312+ positiveQuery "SELECT ?::jsonb ?? ?" (testObj, "foo" :: Text)
313+ negativeQuery "SELECT ?::jsonb ?? ?" (testObj, "baz" :: Text)
314+ negativeQuery "SELECT ?::jsonb ?? ?" (toJSON numArray, "1" :: Text)
315+ -- ?| -> Do any of these array strings exist as top-level keys?
316+ positiveQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","bar","6" :: Text])
317+ negativeQuery "SELECT ?::jsonb ??| ?" (testObj, PGArray ["nope","6" :: Text])
318+ negativeQuery "SELECT ?::jsonb ??| ?" (toJSON numArray, PGArray ["1","2","6" :: Text])
319+ -- ?& -> Do all of these array strings exist as top-level keys?
320+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","quux" :: Text])
321+ positiveQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar" :: Text])
322+ negativeQuery "SELECT ?::jsonb ??& ?" (testObj, PGArray ["foo","bar","baz" :: Text])
323+ negativeQuery "SELECT ?::jsonb ??& ?" (toJSON numArray, PGArray ["1","2","3","4","5" :: Text])
324+ -- Format error for 2 question marks, not 4
325+ True <- expectError (isFormatError 2) $
326+ (query conn "SELECT ?::jsonb ?? ?" $ Only testObj :: IO [Only Bool])
327+ return ()
328+ where positiveQuery :: ToRow a => Query -> a -> Assertion
329+ positiveQuery = boolQuery True
330+ negativeQuery :: ToRow a => Query -> a -> Assertion
331+ negativeQuery = boolQuery False
332+ numArray :: [Int]
333+ numArray = [1,2,3,4,5]
334+ boolQuery :: ToRow a => Bool -> Query -> a -> Assertion
335+ boolQuery b t x = do
336+ a <- query conn t x
337+ [Only b] @?= a
338+ testObj = toJSON (Map.fromList [("foo",toJSON (1 :: Int))
339+ ,("bar",String "baz")
340+ ,("quux",toJSON [1 :: Int,2,3,4,5])] :: Map Text Value
341+ )
342+
221343testSavepoint :: TestEnv -> Assertion
222344testSavepoint TestEnv{..} = do
223345 True <- expectError ST.isNoActiveTransactionError $
@@ -325,6 +447,14 @@ testCopy TestEnv{..} = do
325447 -- so that we can issue more queries:
326448 [Only (x::Int)] <- query_ conn "SELECT 2 + 2"
327449 x @?= 4
450+ -- foldCopyData
451+ copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)"
452+ (acc, count) <- foldCopyData conn
453+ (\acc row -> return (row:acc))
454+ (\acc count -> return (acc, count))
455+ []
456+ sort acc @?= sort copyRows
457+ count @?= 2
328458 where
329459 copyRows = ["1,foo\n"
330460 ,"2,bar\n"]
@@ -344,12 +474,13 @@ testCopyFailures env = testGroup "Copy failures"
344474
345475goldenTest :: TestName -> IO BL.ByteString -> TestTree
346476goldenTest testName =
347− goldenVsString testName (resultsDir </> fileName<.>"expected")
477+ goldenVsStringDiff testName diff (resultsDir </> fileName<.>"expected")
348478 where
349479 resultsDir = "test" </> "results"
350480 fileName = map normalize testName
351481 normalize c | not (isAlpha c) = '-'
352482 | otherwise = c
483+ diff ref new = ["diff", "-u", ref, new]
353484
354485-- | Test that we provide a sensible error message on failure
355486testCopyUniqueConstraintError :: TestEnv -> TestTree
@@ -462,24 +593,56 @@ isUniqueViolation SqlError{..} = sqlState == "23505"
462593isSyntaxError :: SqlError -> Bool
463594isSyntaxError SqlError{..} = sqlState == "42601"
464595
596+isFormatError :: Int -> FormatError -> Bool
597+isFormatError i FormatError{..}
598+ | null fmtMessage = False
599+ | otherwise = fmtMessage == concat [ show i
600+ , " single '?' characters, but "
601+ , show (length fmtParams)
602+ , " parameters"
603+ ]
465604------------------------------------------------------------------------
466605
467606-- | Action for connecting to the database that will be used for testing.
468607--
469608-- Note that some tests, such as Notify, use multiple connections, and assume
470609-- that 'testConnect' connects to the same database every time it is called.
471−testConnect :: IO Connection
472−testConnect = connectPostgreSQL ""
610+withTestEnv :: ByteString -> (TestEnv -> IO a) -> IO a
611+withTestEnv connstr cb =
612+ withConn $ \conn -> do
613+ -- currently required for interval to work.
614+ -- we also test that this doesn't interfere with anything else
615+ execute_ conn "SET intervalstyle TO 'iso_8601'"
473616
474−withTestEnv :: (TestEnv -> IO a) -> IO a
475−withTestEnv cb =
476− withConn $ \conn ->
477617 cb TestEnv
478618 { conn = conn
479619 , withConn = withConn
480620 }
481621 where
482− withConn = bracket testConnect close
622+ withConn = bracket (connectPostgreSQL connstr) close
483623
484624main :: IO ()
485−main = withTestEnv $ defaultMain . tests
625+main = withConnstring $ \connstring -> do
626+ withTestEnv connstring (defaultMain . tests)
627+
628+withConnstring :: (BS8.ByteString -> IO ()) -> IO ()
629+withConnstring kont = do
630+ env <- getEnvironment
631+ case lookup "DATABASE_CONNSTRING" env of
632+ Just s -> kont (BS8.pack (special s))
633+ Nothing -> case lookup "GITHUB_ACTIONS" env of
634+ Just "true" -> kont (BS8.pack gha)
635+ _ -> putStrLn "Set DATABASE_CONNSTRING environment variable"
636+ where
637+ -- https://www.appveyor.com/docs/services-databases/
638+ special "appveyor" = "dbname='TestDb' user='postgres' password='Password12!'"
639+ special "travis" = ""
640+ special s = s
641+
642+ gha = unwords
643+ [ "dbname='postgres'"
644+ , "user='postgres'"
645+ , "password='postgres'"
646+ , "host='postgres'"
647+ , "port=5432"
648+ ]
test/Time.hs+1−1
@@ -36,7 +36,7 @@ module Time (testTime) where
3636
3737import Common
3838import Control.Monad(forM_, replicateM_)
39−import Data.Time
39+import Data.Time.Compat
4040import Data.ByteString(ByteString)
4141import Database.PostgreSQL.Simple.SqlQQ
4242
test/results/malformed-input.expected+1−1
@@ -1,4 +1,4 @@
11user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status
2−Connection error: ERROR: invalid input syntax for integer: "z"
2+Connection error: ERROR: invalid input syntax for type integer: "z"
33CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z"
44)
tools/GenTypeInfo.hs+39−25
@@ -21,6 +21,9 @@
2121-- know about. It then constructs a TypeInfo record and stores it in
2222-- a per-connection cache for later use.
2323--
24+-- @
25+-- runghc -itools tools/GenTypeInfo.hs
26+-- @
2427------------------------------------------------------------------------------
2528
2629{-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-}
@@ -38,12 +41,10 @@ import Database.PostgreSQL.Simple.FromRow
3841import Database.PostgreSQL.Simple.Ok
3942import Database.PostgreSQL.Simple.Types(Oid(..))
4043import Database.PostgreSQL.Simple.SqlQQ
41−import qualified Data.ByteString.Char8 as B
44+import qualified Data.ByteString.Char8 as B8
4245import Data.ByteString(ByteString)
4346import qualified Data.ByteString.Lazy as L
44−import qualified Blaze.ByteString.Builder as Blaze
45−import qualified Blaze.ByteString.Builder.ByteString as Blaze
46−import qualified Blaze.ByteString.Builder.Char8 as Blaze
47+import qualified Data.ByteString.Builder as Blaze
4748import Data.String
4849import Data.List ( sort, intersperse )
4950import qualified Data.Map as Map
@@ -69,11 +70,11 @@ data TypeInfo = TypeInfo
6970instance FromRow TypeInfo where
7071 fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field
7172
72−type NameMap = Map.Map B.ByteString TypeInfo
73+type NameMap = Map.Map B8.ByteString TypeInfo
7374
7475type OidMap = Map.Map Oid TypeInfo
7576
76−type TypeName = (B.ByteString, B.ByteString)
77+type TypeName = (B8.ByteString, B8.ByteString)
7778
7879type TypeNames = [TypeName]
7980
@@ -197,9 +198,6 @@ int8range
197198_int8range
198199|]
199200
200−instance IsString Blaze.Builder where
201− fromString = Blaze.fromByteString . fromString
202−
203201connectionString = "dbname=postgres"
204202
205203withPostgreSQL = bracket (connectPostgreSQL connectionString) close
@@ -237,7 +235,7 @@ getTypeInfos typnames = withPostgreSQL $ \conn -> do
237235
238236main = do
239237 (oidmap, namemap) <- getTypeInfos typeNames
240− L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
238+ L.writeFile "src/Database/PostgreSQL/Simple/TypeInfo/Static.hs"
241239 (Blaze.toLazyByteString (renderFile oidmap namemap typeNames))
242240
243241
@@ -246,7 +244,7 @@ showOid (Oid n) = show n
246244renderOid :: NameMap -> TypeName -> Blaze.Builder
247245renderOid byName name
248246 = case Map.lookup (pg name) byName of
249− Nothing -> error (B.unpack (pg name))
247+ Nothing -> error (B8.unpack (pg name))
250248 Just (showOid . typoid -> n) -> fromString n
251249 ++ fromString (replicate (4 - length n) ' ')
252250
@@ -264,20 +262,25 @@ renderTypeInfo byOid info name
264262 typelem_hs_name =
265263 case lookup (typname typelem_info) typeNames of
266264 Nothing -> error ( "type not found: "
267− ++ B.unpack( typname typelem_info)
268− ++ " (typelem of " ++ B.unpack (typname info)
265+ ++ B8.unpack( typname typelem_info)
266+ ++ " (typelem of " ++ B8.unpack (typname info)
269267 ++ ")")
270268 Just x -> x
271269 in concat
272270 [ "\n"
273271 , bs (hs name), " :: TypeInfo\n"
274272 , bs (hs name), " = Array {\n"
275− , " typoid = ", fromString (show (typoid info)), ",\n"
276− , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
277− , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
273+ , " typoid = ", bs (hs name), "Oid,\n"
274+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
275+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
278276 , " typname = \"", bs (typname info), "\",\n"
279277 , " typelem = ", bs typelem_hs_name, "\n"
280278 , " }\n"
279+ , "\n"
280+ , bs (hs name), "Oid :: Oid\n"
281+ , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
282+ , "{-# INLINE ", bs (hs name), "Oid #-}"
283+ , "\n"
281284 ]
282285 | typcategory info == 'R' =
283286 let (Just rngsubtype_oid) = rngsubtype info
@@ -285,31 +288,41 @@ renderTypeInfo byOid info name
285288 rngsubtype_hs_name =
286289 case lookup (typname rngsubtype_info) typeNames of
287290 Nothing -> error ( "type not found: "
288− ++ B.unpack (typname rngsubtype_info)
291+ ++ B8.unpack (typname rngsubtype_info)
289292 ++ " (rngsubtype of "
290− ++ B.unpack (typname info) ++ ")")
293+ ++ B8.unpack (typname info) ++ ")")
291294 Just x -> x
292295 in concat
293296 [ "\n"
294297 , bs (hs name), " :: TypeInfo\n"
295298 , bs (hs name), " = Range {\n"
296− , " typoid = ", fromString (show (typoid info)), ",\n"
297− , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
298− , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
299+ , " typoid = ", bs (hs name), "Oid,\n"
300+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
301+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
299302 , " typname = \"", bs (typname info), "\",\n"
300303 , " rngsubtype = ", bs rngsubtype_hs_name, "\n"
301304 , " }\n"
305+ , "\n"
306+ , bs (hs name), "Oid :: Oid\n"
307+ , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
308+ , "{-# INLINE ", bs (hs name), "Oid #-}"
309+ , "\n"
302310 ]
303311 | otherwise =
304312 concat
305313 [ "\n"
306314 , bs (hs name), " :: TypeInfo\n"
307315 , bs (hs name), " = Basic {\n"
308− , " typoid = ", fromString (show (typoid info)), ",\n"
309− , " typcategory = '", Blaze.fromChar (typcategory info), "',\n"
310− , " typdelim = '", Blaze.fromChar (typdelim info), "',\n"
316+ , " typoid = ", bs (hs name), "Oid,\n"
317+ , " typcategory = '", bs $ B8.singleton (typcategory info), "',\n"
318+ , " typdelim = '", bs $ B8.singleton (typdelim info), "',\n"
311319 , " typname = \"", bs (typname info), "\"\n"
312320 , " }\n"
321+ , "\n"
322+ , bs (hs name), "Oid :: Oid\n"
323+ , bs (hs name), "Oid = ", fromString (show (typoid info)), "\n"
324+ , "{-# INLINE ", bs (hs name), "Oid #-}"
325+ , "\n"
313326 ]
314327
315328-- FIXME: add in any names that we need that we didn't specify, (i.e.
@@ -318,7 +331,7 @@ renderTypeInfo byOid info name
318331getNames :: NameMap -> TypeNames -> TypeNames
319332getNames _ x = x
320333
321−bs = Blaze.fromByteString
334+bs = Blaze.byteString
322335
323336pg = fst
324337
@@ -347,6 +360,7 @@ module Database.PostgreSQL.Simple.TypeInfo.Static
347360 ( TypeInfo(..)
348361 , staticTypeInfo
349362|] ++ concat [ " , " ++ bs (hs name) ++ "\n"
363+ ++ " , " ++ bs (hs name) ++ "Oid\n"
350364 | name <- names ] ++ [longstring|
351365 ) where
352366