├── .github
└── workflows
│ └── ci.yml
├── .gitignore
├── README.md
├── RELEASE NOTES.md
├── cabal.project
├── scrap-your-nils.md
├── squeal-core-concepts-handbook.md
├── squeal-core-concepts-handbook
├── isqualified-alias.png
├── isqualified-can-be-np.png
├── isqualified-intro.png
└── isqualified-join-constraint.png
├── squeal-postgresql-ltree
├── LICENSE
├── README.md
├── squeal-postgresql-ltree.cabal
└── src
│ └── Squeal
│ └── PostgreSQL
│ └── LTree.hs
├── squeal-postgresql-uuid-ossp
├── LICENSE
├── README.md
├── squeal-postgresql-uuid-ossp.cabal
└── src
│ └── Squeal
│ └── PostgreSQL
│ └── UUID
│ └── OSSP.hs
├── squeal-postgresql
├── LICENSE
├── README.md
├── Setup.hs
├── bench
│ ├── Gauge.hs
│ ├── Gauge
│ │ ├── DBHelpers.hs
│ │ ├── DBSetup.hs
│ │ ├── Queries.hs
│ │ └── Schema.hs
│ └── README.md
├── docs-upload.sh
├── exe
│ └── Example.hs
├── squeal-postgresql.cabal
├── src
│ └── Squeal
│ │ ├── PostgreSQL.hs
│ │ └── PostgreSQL
│ │ ├── Definition.hs
│ │ ├── Definition
│ │ ├── Comment.hs
│ │ ├── Constraint.hs
│ │ ├── Function.hs
│ │ ├── Index.hs
│ │ ├── Procedure.hs
│ │ ├── Schema.hs
│ │ ├── Table.hs
│ │ ├── Type.hs
│ │ └── View.hs
│ │ ├── Expression.hs
│ │ ├── Expression
│ │ ├── Aggregate.hs
│ │ ├── Array.hs
│ │ ├── Comparison.hs
│ │ ├── Composite.hs
│ │ ├── Default.hs
│ │ ├── Inline.hs
│ │ ├── Json.hs
│ │ ├── Logic.hs
│ │ ├── Math.hs
│ │ ├── Null.hs
│ │ ├── Parameter.hs
│ │ ├── Range.hs
│ │ ├── Sort.hs
│ │ ├── Subquery.hs
│ │ ├── Text.hs
│ │ ├── TextSearch.hs
│ │ ├── Time.hs
│ │ ├── Type.hs
│ │ └── Window.hs
│ │ ├── Manipulation.hs
│ │ ├── Manipulation
│ │ ├── Call.hs
│ │ ├── Delete.hs
│ │ ├── Insert.hs
│ │ └── Update.hs
│ │ ├── Query.hs
│ │ ├── Query
│ │ ├── From.hs
│ │ ├── From
│ │ │ ├── Join.hs
│ │ │ └── Set.hs
│ │ ├── Select.hs
│ │ ├── Table.hs
│ │ ├── Values.hs
│ │ └── With.hs
│ │ ├── Render.hs
│ │ ├── Session.hs
│ │ ├── Session
│ │ ├── Connection.hs
│ │ ├── Decode.hs
│ │ ├── Encode.hs
│ │ ├── Exception.hs
│ │ ├── Indexed.hs
│ │ ├── Migration.hs
│ │ ├── Monad.hs
│ │ ├── Oid.hs
│ │ ├── Pool.hs
│ │ ├── Result.hs
│ │ ├── Statement.hs
│ │ ├── Transaction.hs
│ │ └── Transaction
│ │ │ └── Unsafe.hs
│ │ ├── Type.hs
│ │ └── Type
│ │ ├── Alias.hs
│ │ ├── List.hs
│ │ ├── PG.hs
│ │ └── Schema.hs
└── test
│ ├── Doc.hs
│ ├── Property.hs
│ └── Spec.hs
├── squeal-presentation-raveline.md
├── squeal-presentation.pdf
├── squeal.gif
├── stack-ghc8_10.yaml
├── stack-ghc8_8.yaml
├── stack-ghc9_0.yaml
├── stack-ghc9_2.yaml
├── stack-ghc9_4.yaml
└── stack.yaml
/.github/workflows/ci.yml:
--------------------------------------------------------------------------------
1 | name: CI
2 |
3 | on:
4 | push:
5 | branches: [ dev ]
6 | pull_request:
7 | branches: [ dev ]
8 |
9 | jobs:
10 | ghc_default:
11 | runs-on: ubuntu-latest
12 |
13 | services:
14 | postgres:
15 | image: postgres:11
16 | env:
17 | POSTGRES_USER: postgres
18 | POSTGRES_PASSWORD: postgres
19 | POSTGRES_DB: exampledb
20 | ports:
21 | - 5432:5432
22 | # needed because the postgres container does not provide a healthcheck
23 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5
24 |
25 | steps:
26 | - uses: actions/checkout@v4
27 | - uses: haskell-actions/setup@v2
28 | with:
29 | enable-stack: true
30 | stack-version: 'latest'
31 | stack-no-global: true
32 | stack-setup-ghc: true
33 |
34 | - name: build
35 | run: stack build --fast
36 |
37 | - name: test
38 | run: stack test --fast
39 | env:
40 | PG_USER: postgres
41 | PG_HOST: localhost
42 | PG_DATABASE: exampledb
43 | PG_PASSWORD: postgres
44 | PG_PORT: ${{ job.services.postgres.ports['5432'] }}
45 |
46 | - name: benchmark
47 | run: stack bench --fast
48 |
49 | - name: documentation
50 | run: stack haddock --fast
51 |
52 | - name: cache
53 | uses: actions/cache@v3
54 | with:
55 | path: |
56 | ".stack-work"
57 | "/root/.stack/"
58 | key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }}
59 | ghc9_4:
60 | runs-on: ubuntu-latest
61 |
62 | services:
63 | postgres:
64 | image: postgres:11
65 | env:
66 | POSTGRES_USER: postgres
67 | POSTGRES_PASSWORD: postgres
68 | POSTGRES_DB: exampledb
69 | ports:
70 | - 5432:5432
71 | # needed because the postgres container does not provide a healthcheck
72 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5
73 |
74 | steps:
75 | - uses: actions/checkout@v2
76 | - uses: haskell-actions/setup@v2
77 | with:
78 | enable-stack: true
79 | stack-version: 'latest'
80 | stack-no-global: true
81 | stack-setup-ghc: true
82 |
83 | - name: build
84 | run: stack build --fast --stack-yaml stack-ghc9_4.yaml
85 |
86 | - name: test
87 | run: stack test --fast --stack-yaml stack-ghc9_4.yaml
88 | env:
89 | PG_USER: postgres
90 | PG_HOST: localhost
91 | PG_DATABASE: exampledb
92 | PG_PASSWORD: postgres
93 | PG_PORT: ${{ job.services.postgres.ports['5432'] }}
94 |
95 | - name: benchmark
96 | run: stack bench --fast --stack-yaml stack-ghc9_4.yaml
97 |
98 | - name: documentation
99 | run: stack haddock --fast --stack-yaml stack-ghc9_4.yaml
100 |
101 | - name: cache
102 | uses: actions/cache@v3
103 | with:
104 | path: |
105 | ".stack-work"
106 | "/root/.stack/"
107 | key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }}
108 | ghc9_2:
109 | runs-on: ubuntu-latest
110 |
111 | services:
112 | postgres:
113 | image: postgres:11
114 | env:
115 | POSTGRES_USER: postgres
116 | POSTGRES_PASSWORD: postgres
117 | POSTGRES_DB: exampledb
118 | ports:
119 | - 5432:5432
120 | # needed because the postgres container does not provide a healthcheck
121 | options: --health-cmd pg_isready --health-interval 10s --health-timeout 5s --health-retries 5
122 |
123 | steps:
124 | - uses: actions/checkout@v2
125 | - uses: haskell-actions/setup@v2
126 | with:
127 | enable-stack: true
128 | stack-version: 'latest'
129 | stack-no-global: true
130 | stack-setup-ghc: true
131 |
132 | - name: build
133 | run: stack build --fast --stack-yaml stack-ghc9_2.yaml
134 |
135 | - name: test
136 | run: stack test --fast --stack-yaml stack-ghc9_2.yaml
137 | env:
138 | PG_USER: postgres
139 | PG_HOST: localhost
140 | PG_DATABASE: exampledb
141 | PG_PASSWORD: postgres
142 | PG_PORT: ${{ job.services.postgres.ports['5432'] }}
143 |
144 | - name: benchmark
145 | run: stack bench --fast --stack-yaml stack-ghc9_2.yaml
146 |
147 | - name: documentation
148 | run: stack haddock --fast --stack-yaml stack-ghc9_2.yaml
149 |
150 | - name: cache
151 | uses: actions/cache@v3
152 | with:
153 | path: |
154 | ".stack-work"
155 | "/root/.stack/"
156 | key: ${{ runner.os }}-${{ hashFiles('**/lockfiles') }}
157 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | dist
2 | dist-*
3 | cabal-dev
4 | *.o
5 | *.hi
6 | *.chi
7 | *.chs.h
8 | *.dyn_o
9 | *.dyn_hi
10 | .hpc
11 | .hsenv
12 | .cabal-sandbox/
13 | cabal.sandbox.config
14 | *.prof
15 | *.aux
16 | *.hp
17 | *.eventlog
18 | .stack-work/
19 | cabal.project.local
20 | .DS_Store
21 | stack.yaml.lock
22 | *.yaml.lock
23 | tags
24 | .*.swp
25 |
--------------------------------------------------------------------------------
/cabal.project:
--------------------------------------------------------------------------------
1 | packages:
2 | squeal-postgresql
3 | , squeal-postgresql-ltree
4 | , squeal-postgresql-uuid-ossp
5 |
--------------------------------------------------------------------------------
/scrap-your-nils.md:
--------------------------------------------------------------------------------
1 | ## Scrap your Nils
2 |
3 | One of the most useful types I've come across in Haskell is the type of
4 | "heterogeneous lists". This is the same as the [Rec](http://hackage.haskell.org/package/vinyl-0.8.1.1/docs/Data-Vinyl-Core.html)
5 | datatype from the [vinyl](http://hackage.haskell.org/package/vinyl) library.
6 | It's also the same as the [NP](http://hackage.haskell.org/package/generics-sop-0.3.2.0/docs/Generics-SOP-NP.html)
7 | datatype from the [generics-sop](http://hackage.haskell.org/package/generics-sop) library.
8 | Squeal makes heavy use of this type.
9 |
10 | ```Haskell
11 | >>> import Generics.SOP (NP(..))
12 | >>> :i NP
13 | type role NP representational nominal
14 | data NP (a :: k -> *) (b :: [k]) where
15 | Nil :: forall k (a :: k -> *). NP a '[]
16 | (:*) :: forall k (a :: k -> *) (x :: k) (xs :: [k]).
17 | (a x) -> (NP a xs) -> NP a (x : xs)
18 | -- Defined in ‘Generics.SOP.NP’
19 | ```
20 |
21 | This type allows us to construct "product" types, where the types of the individual
22 | "terms" are hosted at the type level.
23 |
24 | ```Haskell
25 | >>> :set -XDataKinds
26 | >>> import Generics.SOP (I(..))
27 | >>> let example = I "foo" :* I pi :* Nil :: NP I '[String, Double]
28 | >>> example
29 | I "foo" :* I 3.141592653589793 :* Nil
30 | ```
31 |
32 | One thing Squeal uses `NP` for is to form lists of aliases,
33 | using GHC's `OverloadedLabels` extension, hosting the names
34 | of the aliases themselves at the type level.
35 |
36 | ```Haskell
37 | >>> :set -XKindSignatures -XOverloadedLabels -XFlexibleInstances -XMultiParamTypeClasses
38 | >>> import GHC.TypeLits
39 | >>> import GHC.OverloadedLabels
40 | >>> data Alias (alias :: Symbol) = Alias deriving (Eq,Ord,Show)
41 | >>> instance IsLabel label (Alias label) where fromLabel = Alias
42 | >>> let aliases = #foo :* #bar :* Nil :: NP Alias '["foo", "bar"]
43 | ```
44 |
45 | However, it's very ugly to have to end every list with `:* Nil`.
46 | When I announced the release of Squeal, people rightly [complained](https://www.reddit.com/r/haskell/comments/6yr5v6/announcing_squeal_a_deep_embedding_of_sql_in/dmq8vvn)
47 | about the syntactic noise. Luckily, there's a neat trick we can use to get rid of it.
48 | Making an `IsLabel` instance not only for elements of our list
49 | but also for lists of length 1, we can ask GHC to interpret
50 | the last label as a list.
51 |
52 | ```Haskell
53 | >>> instance IsLabel label (NP Alias '[label]) where fromLabel = Alias :* Nil
54 | >>> let aliases' = #foo :* #bar :: NP Alias '["foo", "bar"]
55 | ```
56 |
57 | Version 0.3.1 of Squeal enables the "Scrap your Nils" trick for
58 | heterogeneous lists of `Alias`es, `Aliased` expressions, `PGlabel`s and `By`s
59 | with the typeclasses `IsLabel`, `IsQualified`, `IsPGlabel`,
60 | and the new `Aliasable` typeclass, to eliminate all need of using `Nil` in a list.
61 |
--------------------------------------------------------------------------------
/squeal-core-concepts-handbook/isqualified-alias.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-alias.png
--------------------------------------------------------------------------------
/squeal-core-concepts-handbook/isqualified-can-be-np.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-can-be-np.png
--------------------------------------------------------------------------------
/squeal-core-concepts-handbook/isqualified-intro.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-intro.png
--------------------------------------------------------------------------------
/squeal-core-concepts-handbook/isqualified-join-constraint.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-core-concepts-handbook/isqualified-join-constraint.png
--------------------------------------------------------------------------------
/squeal-postgresql-ltree/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2020 Morphism, LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are
7 | met:
8 |
9 | * Redistributions of source code must retain the above copyright
10 | notice, this list of conditions and the following disclaimer.
11 |
12 | * Redistributions in binary form must reproduce the above
13 | copyright notice, this list of conditions and the following
14 | disclaimer in the documentation and/or other materials provided
15 | with the distribution.
16 |
17 | * Neither the names of the copyright holders nor the names of the
18 | contributors may be used to endorse or promote products derived
19 | from this software without specific prior written permission.
20 |
21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--------------------------------------------------------------------------------
/squeal-postgresql-ltree/README.md:
--------------------------------------------------------------------------------
1 | # squeal-postgresql-ltree
2 |
--------------------------------------------------------------------------------
/squeal-postgresql-ltree/squeal-postgresql-ltree.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.2
2 | name: squeal-postgresql-ltree
3 | version: 0.1.0.2
4 | synopsis: LTree extension for Squeal
5 | description: LTree extension for Squeal
6 | homepage: https://github.com/morphismtech/squeal/ltree
7 | bug-reports: https://github.com/morphismtech/squeal/issues
8 | license: BSD-3-Clause
9 | license-file: LICENSE
10 | author: Eitan Chatav
11 | maintainer: eitan.chatav@gmail.com
12 | copyright: Copyright (c) 2022 Morphism, LLC
13 | category: Database
14 | build-type: Simple
15 | extra-doc-files: README.md
16 |
17 | source-repository head
18 | type: git
19 | location: https://github.com/morphismtech/squeal.git
20 |
21 | library
22 | hs-source-dirs: src
23 | exposed-modules:
24 | Squeal.PostgreSQL.LTree
25 | default-language: Haskell2010
26 | ghc-options: -Wall
27 | build-depends:
28 | base >= 4.12.0.0 && < 5.0
29 | , bytestring >= 0.10.10.0
30 | , generics-sop >= 0.5.1.0
31 | , mtl >= 2.2.2
32 | , postgresql-binary >= 0.12.2
33 | , postgresql-libpq >= 0.9.4.2
34 | , squeal-postgresql >= 0.7.0.1
35 | , text >= 1.2.3.2
36 |
--------------------------------------------------------------------------------
/squeal-postgresql-uuid-ossp/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2020 Morphism, LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are
7 | met:
8 |
9 | * Redistributions of source code must retain the above copyright
10 | notice, this list of conditions and the following disclaimer.
11 |
12 | * Redistributions in binary form must reproduce the above
13 | copyright notice, this list of conditions and the following
14 | disclaimer in the documentation and/or other materials provided
15 | with the distribution.
16 |
17 | * Neither the names of the copyright holders nor the names of the
18 | contributors may be used to endorse or promote products derived
19 | from this software without specific prior written permission.
20 |
21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--------------------------------------------------------------------------------
/squeal-postgresql-uuid-ossp/README.md:
--------------------------------------------------------------------------------
1 | # squeal-postgresql-uuid-ossp
2 |
--------------------------------------------------------------------------------
/squeal-postgresql-uuid-ossp/squeal-postgresql-uuid-ossp.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.2
2 | name: squeal-postgresql-uuid-ossp
3 | version: 0.1.0.1
4 | synopsis: UUID OSSP extension for Squeal
5 | description: UUID OSSP extension for Squeal
6 | homepage: https://github.com/morphismtech/squeal/uuid-ossp
7 | bug-reports: https://github.com/morphismtech/squeal/issues
8 | license: BSD-3-Clause
9 | license-file: LICENSE
10 | author: Eitan Chatav
11 | maintainer: eitan.chatav@gmail.com
12 | copyright: Copyright (c) 2022 Morphism, LLC
13 | category: Database
14 | build-type: Simple
15 | extra-doc-files: README.md
16 |
17 | source-repository head
18 | type: git
19 | location: https://github.com/morphismtech/squeal.git
20 |
21 | library
22 | hs-source-dirs: src
23 | exposed-modules:
24 | Squeal.PostgreSQL.UUID.OSSP
25 | default-language: Haskell2010
26 | ghc-options: -Wall
27 | build-depends:
28 | base >= 4.12.0.0 && < 5.0
29 | , squeal-postgresql >= 0.7.0.1
30 |
--------------------------------------------------------------------------------
/squeal-postgresql-uuid-ossp/src/Squeal/PostgreSQL/UUID/OSSP.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.UUID.OSSP
3 | Description: uuid-ossp
4 | Copyright: (c) Eitan Chatav, 2020
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | This module provides functions to generate universally
9 | unique identifiers (UUIDs) using one of several standard algorithms.
10 | There are also functions to produce certain special UUID constants.
11 | -}
12 |
13 | {-# LANGUAGE
14 | DataKinds
15 | , OverloadedStrings
16 | , TypeOperators
17 | #-}
18 |
19 | module Squeal.PostgreSQL.UUID.OSSP
20 | ( -- * Definition
21 | createUuidOssp
22 | -- * Generation
23 | , uuidGenerateV1
24 | , uuidGenerateV1mc
25 | , uuidGenerateV3
26 | , uuidGenerateV4
27 | , uuidGenerateV5
28 | -- * Constants
29 | , uuidNil
30 | , uuidNSUrl
31 | , uuidNSDns
32 | , uuidNSOid
33 | , uuidNSX500
34 | ) where
35 |
36 | import Squeal.PostgreSQL
37 |
38 | -- | Loads ltree extension into the current database.
39 | createUuidOssp :: Definition db db
40 | createUuidOssp = UnsafeDefinition "CREATE EXTENSION \"uuid-ossp\";"
41 |
42 | -- | This function generates a version 1 UUID.
43 | -- This involves the MAC address of the computer and a time stamp.
44 | -- Note that UUIDs of this kind reveal the identity of the computer
45 | -- that created the identifier and the time at which it did so,
46 | -- which might make it unsuitable for certain security-sensitive applications.
47 | uuidGenerateV1 :: Expr (null 'PGuuid)
48 | uuidGenerateV1 = UnsafeExpression "uuid_generate_v1()"
49 |
50 | -- | This function generates a version 1 UUID but uses a random multicast
51 | -- MAC address instead of the real MAC address of the computer.
52 | uuidGenerateV1mc :: Expr (null 'PGuuid)
53 | uuidGenerateV1mc = UnsafeExpression "uuid_generate_v1mc()"
54 |
55 | {- | This function generates a version 3 UUID in the given namespace
56 | using the specified input name. The namespace should be one of the
57 | special constants produced by the uuidNS* functions.
58 | (It could be any UUID in theory.)
59 | The name is an identifier in the selected namespace.
60 | For example:
61 | @
62 | uuidGenerateV3 (uuidNSUrl *: "http://www.postgresql.org")
63 | @
64 |
65 | The name parameter will be MD5-hashed,
66 | so the cleartext cannot be derived from the generated UUID.
67 | The generation of UUIDs by this method has no random or
68 | environment-dependent element and is therefore reproducible.
69 | -}
70 | uuidGenerateV3 :: '[null 'PGuuid, null 'PGtext] ---> null 'PGuuid
71 | uuidGenerateV3 = unsafeFunctionN "uuid_generate_v3"
72 |
73 | {- | This function generates a version 4 UUID,
74 | which is derived entirely from random numbers.
75 | -}
76 | uuidGenerateV4 :: Expr (null 'PGuuid)
77 | uuidGenerateV4 = UnsafeExpression "uuid_generate_v4()"
78 |
79 | {- | This function generates a version 5 UUID,
80 | which works like a version 3 UUID except that
81 | SHA-1 is used as a hashing method.
82 | Version 5 should be preferred over version 3 because
83 | SHA-1 is thought to be more secure than MD5.
84 | -}
85 | uuidGenerateV5 :: '[null 'PGuuid, null 'PGtext] ---> null 'PGuuid
86 | uuidGenerateV5 = unsafeFunctionN "uuid_generate_v5"
87 |
88 | -- | A "nil" UUID constant, which does not occur as a real UUID.
89 | uuidNil :: Expr (null 'PGuuid)
90 | uuidNil = UnsafeExpression "uuid_nil()"
91 |
92 | -- | Constant designating the DNS namespace for UUIDs.
93 | uuidNSDns :: Expr (null 'PGuuid)
94 | uuidNSDns = UnsafeExpression "uuid_ns_dns()"
95 |
96 | -- | Constant designating the URL namespace for UUIDs.
97 | uuidNSUrl :: Expr (null 'PGuuid)
98 | uuidNSUrl = UnsafeExpression "uuid_ns_url()"
99 |
100 | -- | Constant designating the ISO object identifier (OID) namespace for UUIDs.
101 | -- (This pertains to ASN.1 OIDs,
102 | -- which are unrelated to the OIDs used in PostgreSQL.)
103 | uuidNSOid :: Expr (null 'PGuuid)
104 | uuidNSOid = UnsafeExpression "uuid_ns_oid()"
105 |
106 | -- | Constant designating the X.500 distinguished
107 | -- name (DN) namespace for UUIDs.
108 | uuidNSX500 :: Expr (null 'PGuuid)
109 | uuidNSX500 = UnsafeExpression "uuid_ns_x500()"
110 |
--------------------------------------------------------------------------------
/squeal-postgresql/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2017 Morphism, LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are
7 | met:
8 |
9 | * Redistributions of source code must retain the above copyright
10 | notice, this list of conditions and the following disclaimer.
11 |
12 | * Redistributions in binary form must reproduce the above
13 | copyright notice, this list of conditions and the following
14 | disclaimer in the documentation and/or other materials provided
15 | with the distribution.
16 |
17 | * Neither the names of the copyright holders nor the names of the
18 | contributors may be used to endorse or promote products derived
19 | from this software without specific prior written permission.
20 |
21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--------------------------------------------------------------------------------
/squeal-postgresql/README.md:
--------------------------------------------------------------------------------
1 | # squeal-postgresql
2 |
3 | 
4 |
5 | [](https://github.com/morphismtech/squeal/actions/workflows/ci.yml)
6 |
7 | [Github](https://github.com/morphismtech/squeal)
8 |
9 | [Hackage](https://hackage.haskell.org/package/squeal-postgresql)
10 |
11 | [Stackage](https://www.stackage.org/package/squeal-postgresql)
12 |
--------------------------------------------------------------------------------
/squeal-postgresql/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/squeal-postgresql/bench/Gauge.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveGeneric #-}
2 | {-# LANGUAGE DataKinds #-}
3 | {-# LANGUAGE OverloadedLabels #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE OverloadedStrings #-}
6 | {-# LANGUAGE TypeApplications #-}
7 | {-# LANGUAGE TypeOperators #-}
8 | {-# LANGUAGE GADTs #-}
9 | {-# LANGUAGE DeriveGeneric #-}
10 | {-# LANGUAGE ScopedTypeVariables #-}
11 |
12 | module Main where
13 |
14 | import Squeal.PostgreSQL hiding ( defaultMain )
15 | import Gauge.Main
16 | import Gauge.Main.Options ( defaultConfig
17 | , Config(..)
18 | , Verbosity(..)
19 | , DisplayMode(..)
20 | , Mode(..)
21 | )
22 | import GHC.Generics
23 | import qualified Generics.SOP as SOP
24 | import Test.QuickCheck
25 | -- For CI
26 | import Main.Utf8 ( withUtf8 )
27 | -- For keeping a track of which question ID to query
28 | import Data.Int ( Int64 )
29 | import Data.IORef
30 | -- Project imports
31 | import Gauge.Schema
32 | import Gauge.Queries
33 | import Gauge.DBSetup ( teardownDB )
34 | import Gauge.DBHelpers ( initDBWithPool
35 | , getRandomUser
36 | , runDbWithPool
37 | , SquealPool
38 | )
39 |
40 | main :: IO ()
41 | main = do
42 | -- A mutable hack here to keep track of
43 | -- pulling a new user by ID from the db instead of the same id
44 | currentId <- newIORef (1 :: UserId)
45 |
46 | -- Define benchmarks
47 | let
48 | queryRenderGroup :: Benchmark
49 | queryRenderGroup = bgroup
50 | "Render Queries"
51 | [ bench "createUser: weak head normal form" $ whnf renderSQL createUser
52 | , bench "createUser: normal form" $ nf renderSQL createUser
53 | , bench "userDetails: weak head normal form" $ whnf renderSQL userDetails
54 | , bench "userDetails: normal form" $ nf renderSQL userDetails
55 | , bench "insertDeviceDetails: weak head normal form"
56 | $ whnf renderSQL insertDeviceDetails
57 | , bench "insertDeviceDetails: normal form"
58 | $ nf renderSQL insertDeviceDetails
59 | ]
60 |
61 | -- Queries against an actual DB
62 |
63 | -- 1. Initialize Schema to DB
64 | -- 2. Make connection pool and pass it to tests
65 | -- 3. Generate users on the fly and add them to DB
66 | -- 4. Tear the Schema down from the DB
67 |
68 | dbInsertsGroup :: Benchmark
69 | dbInsertsGroup =
70 | envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup
71 | "Run individual INSERTs against DB using a connection pool"
72 | [ bgroup
73 | "INSERT: add users to the table users"
74 | [ bench "Run individual INSERT statement" $ makeRunOnce $ perRunEnv
75 | getRandomUser
76 | -- The actual action to benchmark
77 | (\(user :: InsertUser) ->
78 | runDbWithPool pool $ createUserSession user
79 | )
80 | ]
81 | ]
82 |
83 | dbSelectsGroup :: Benchmark
84 | dbSelectsGroup =
85 | envWithCleanup initDBWithPool (const teardownDB) $ \pool -> bgroup
86 | "Run individual SELECTs against DB using a connection pool"
87 | [ bgroup
88 | "SELECT: fetch users from the table users individually"
89 | [ bench "Fetch a single user" $ makeRunOnce $ perRunEnv
90 | (insertAndIncrement pool currentId)
91 | (\(id_ :: UserId) -> runDbWithPool pool $ userDetailsSession id_
92 | )
93 | ]
94 | ]
95 |
96 | withUtf8 $ defaultMain [queryRenderGroup, dbInsertsGroup, dbSelectsGroup]
97 |
98 |
99 | -- | Configure the benchmark to run only once (per IO action)
100 | makeRunOnce :: Benchmarkable -> Benchmarkable
101 | makeRunOnce current = current { perRun = True }
102 |
103 | getAndIncrementId :: (IORef UserId) -> IO UserId
104 | getAndIncrementId currentId = do
105 | current <- readIORef currentId
106 | writeIORef currentId (current + 1)
107 | return current
108 |
109 | -- | This INSERTs a row in the db so that there's always a row to query.
110 | -- Otherwise 'getRow 0' throws an exception.
111 | -- NOTE: will make benchmark time slower but does not affect results.
112 | insertAndIncrement :: SquealPool -> (IORef UserId) -> IO UserId
113 | insertAndIncrement pool currentId = do
114 | user <- getRandomUser
115 | _ <- runDbWithPool pool $ createUserSession user
116 | getAndIncrementId currentId
117 |
--------------------------------------------------------------------------------
/squeal-postgresql/bench/Gauge/DBHelpers.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveGeneric #-}
2 | {-# LANGUAGE DataKinds #-}
3 | {-# LANGUAGE OverloadedLabels #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE OverloadedStrings #-}
6 | {-# LANGUAGE TypeApplications #-}
7 | {-# LANGUAGE TypeOperators #-}
8 | {-# LANGUAGE GADTs #-}
9 | {-# LANGUAGE DeriveGeneric #-}
10 | {-# LANGUAGE DeriveAnyClass #-}
11 | {-# LANGUAGE DerivingStrategies #-}
12 | {-# LANGUAGE ScopedTypeVariables #-}
13 | {-# LANGUAGE StandaloneDeriving #-}
14 |
15 | module Gauge.DBHelpers where
16 |
17 | import qualified Data.ByteString.Char8 as C
18 | import qualified Data.Text as T
19 | import Control.Monad ( void )
20 | import Control.Monad.IO.Class ( liftIO )
21 | import Control.Monad.Loops ( iterateWhile )
22 | import GHC.Generics ( Generic )
23 | import Test.QuickCheck
24 | import Squeal.PostgreSQL
25 | import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe
26 | import Control.DeepSeq
27 | -- Project imports
28 | import Gauge.Schema ( Schemas )
29 | import Gauge.Queries ( InsertUser(..) )
30 | import Gauge.DBSetup
31 |
32 | newtype SquealPool = SquealPool {getSquealPool :: Pool (K Connection Schemas)} deriving (Generic)
33 | -- Below may be wrong - it may screw up the whole connection pool using in tests
34 | instance NFData SquealPool where
35 | rnf = rwhnf
36 |
37 | runDbErr
38 | :: SquealPool -> PQ Schemas Schemas IO b -> IO (Either SquealException b)
39 | runDbErr pool session = do
40 | liftIO . runUsingConnPool pool $ trySqueal (Unsafe.transactionally_ session)
41 |
42 | runDbWithPool :: SquealPool -> PQ Schemas Schemas IO b -> IO b
43 | runDbWithPool pool session = do
44 | errOrResult <- runDbErr pool session
45 | case errOrResult of
46 | Left err -> throwSqueal err
47 | Right result -> return result
48 |
49 | -- | Helper
50 | runUsingConnPool :: SquealPool -> PQ Schemas Schemas IO x -> IO x
51 | runUsingConnPool (SquealPool pool) = usingConnectionPool pool
52 |
53 | makePool :: C.ByteString -> IO SquealPool
54 | makePool connStr = do
55 | pool <- createConnectionPool connStr 1 0.5 10
56 | return $ SquealPool pool
57 |
58 | initDBWithPool :: IO SquealPool
59 | initDBWithPool = do
60 | void initDB
61 | pool <- makePool connectionString
62 | return pool
63 |
64 | getRandomUser :: IO InsertUser
65 | getRandomUser = iterateWhile noEmptyEmail $ generate arbitrary
66 | where
67 | noEmptyEmail InsertUser { userEmail = userEmail } = T.length userEmail < 5
68 |
--------------------------------------------------------------------------------
/squeal-postgresql/bench/Gauge/DBSetup.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveGeneric #-}
2 | {-# LANGUAGE DataKinds #-}
3 | {-# LANGUAGE OverloadedLabels #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE OverloadedStrings #-}
6 | {-# LANGUAGE TypeApplications #-}
7 | {-# LANGUAGE TypeOperators #-}
8 | {-# LANGUAGE GADTs #-}
9 | {-# LANGUAGE DeriveGeneric #-}
10 | {-# LANGUAGE DeriveAnyClass #-}
11 | {-# LANGUAGE DerivingStrategies #-}
12 | {-# LANGUAGE ScopedTypeVariables #-}
13 |
14 | module Gauge.DBSetup where
15 |
16 | import Data.ByteString ( ByteString )
17 | import qualified Data.ByteString.Char8 as C
18 | import Control.Monad ( void )
19 | import GHC.Generics
20 | import Squeal.PostgreSQL
21 | -- Project imports
22 | import Gauge.Schema ( Schemas
23 | , DeviceOS
24 | , IPLocation
25 | )
26 |
27 |
28 | -- First create enums as they're needed in the Schema
29 | setup :: Definition (Public '[]) Schemas
30 | setup =
31 | createTypeEnumFrom @DeviceOS #device_os
32 | >>> createTypeCompositeFrom @IPLocation #ip_location
33 | >>> createTable
34 | #users
35 | ( serial8
36 | `as` #id
37 | :* (text & notNullable)
38 | `as` #email
39 | :* (text & notNullable)
40 | `as` #password
41 | :* (text & nullable)
42 | `as` #first_name
43 | :* (int2 & nullable)
44 | `as` #birthyear
45 | )
46 | (primaryKey #id `as` #pk_users :* unique #email `as` #email)
47 | >>> createTable
48 | #user_devices
49 | ( serial8
50 | `as` #id
51 | :* notNullable int8
52 | `as` #user_id
53 | :* (text & notNullable)
54 | `as` #token
55 | :* (typedef #device_os & notNullable)
56 | `as` #os
57 | )
58 | ( primaryKey #id
59 | `as` #pk_user_devices
60 | :* foreignKey #user_id #users #id (OnDelete Cascade) (OnUpdate Cascade)
61 | `as` #fk_user_id
62 | :* unique #token
63 | `as` #token
64 | )
65 |
66 | -- Drop types last because tables depend on them
67 | teardown :: Definition Schemas (Public '[])
68 | teardown =
69 | dropTableCascade #user_devices
70 | >>> dropTableCascade #users
71 | >>> dropType #ip_location
72 | >>> dropType #device_os
73 |
74 | -- With env vars, we could use the commented keys
75 | data PGConfig = PGConfig
76 | { pgHost :: String -- "PG_HOST"
77 | , pgPort :: Int -- "PG_PORT"
78 | , pgDbname :: String -- "PG_DBNAME"
79 | , pgUser :: String -- "PG_USER"
80 | , pgPassword :: String -- "PG_PASSWORD"
81 | }
82 | deriving (Generic, Show)
83 |
84 | -- | Helper: unused now, but primarily for testing locally
85 | makeConnStr :: PGConfig -> ByteString
86 | makeConnStr PGConfig { pgHost = host, pgPort = portNumber, pgDbname = dbName, pgUser = user, pgPassword = pw }
87 | = C.pack
88 | $ "host="
89 | <> host
90 | <> " dbname="
91 | <> dbName
92 | <> " user="
93 | <> user
94 | <> " password="
95 | <> pw
96 | <> " port="
97 | <> show portNumber
98 |
99 | connectionString :: ByteString
100 | connectionString = "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
101 |
102 | performDBAction :: Definition a b -> String -> IO ()
103 | performDBAction action message = do
104 | void
105 | $ withConnection connectionString
106 | $ manipulate_ (UnsafeManipulation "SET client_min_messages TO WARNING;")
107 | & pqThen (define action)
108 | putStrLn message
109 |
110 | initDB :: IO ()
111 | initDB =
112 | performDBAction setup "Initialized Schema & corresponding tables for Database"
113 |
114 | teardownDB :: IO ()
115 | teardownDB = performDBAction teardown "Dropped all database tables"
116 |
117 | dbSchema :: Definition '["public" ::: '[]] (Drop "public" '["public" ::: '[]])
118 | dbSchema = dropSchemaCascade #public
119 |
120 | dropDBSchema :: IO ()
121 | dropDBSchema = performDBAction dbSchema "Dropped Public schema from database"
122 |
123 | -- | Concatenate two `ByteString`s with a space between.
124 | (<+>) :: ByteString -> ByteString -> ByteString
125 | infixr 7 <+>
126 | str1 <+> str2 = str1 <> " " <> str2
127 |
128 | -- | Drop table custom SQL statement with 'cascade'
129 | dropTableCascade
130 | :: (Has sch schemas schema, Has tab schema ( 'Table table))
131 | => QualifiedAlias sch tab -- ^ table to remove
132 | -> Definition schemas (Alter sch (Drop tab schema) schemas)
133 | dropTableCascade tab =
134 | UnsafeDefinition $ "DROP TABLE" <+> renderSQL tab <> " cascade;"
135 |
--------------------------------------------------------------------------------
/squeal-postgresql/bench/Gauge/Queries.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveGeneric #-}
2 | {-# LANGUAGE DataKinds #-}
3 | {-# LANGUAGE OverloadedLabels #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE OverloadedStrings #-}
6 | {-# LANGUAGE TypeApplications #-}
7 | {-# LANGUAGE TypeOperators #-}
8 | {-# LANGUAGE GADTs #-}
9 | {-# LANGUAGE DeriveGeneric #-}
10 | {-# LANGUAGE DeriveAnyClass #-}
11 | {-# LANGUAGE DerivingStrategies #-}
12 |
13 | module Gauge.Queries where
14 |
15 | import Squeal.PostgreSQL
16 | import GHC.Generics ( Generic )
17 | import qualified Generics.SOP as SOP
18 | -- Need below for deriving instances
19 | import Control.DeepSeq
20 | import Data.Text ( Text )
21 | import Data.Int ( Int16
22 | , Int64
23 | )
24 | import Test.QuickCheck ( Arbitrary(..) )
25 | import Generic.Random ( genericArbitrarySingle )
26 | -- Import Orphan instances
27 | import Test.QuickCheck.Instances ( )
28 | -- Project imports
29 | import Gauge.Schema
30 |
31 | -- Types
32 |
33 | type UserId = Int64
34 | -- Insert user
35 | data InsertUser = InsertUser
36 | { userEmail :: Text
37 | , userPassword :: Text
38 | , userFirstName :: Maybe Text
39 | , userBirthyear :: Maybe Int16
40 | }
41 | deriving (Show, Eq, Generic, NFData)
42 | instance SOP.Generic InsertUser
43 | instance SOP.HasDatatypeInfo InsertUser
44 | -- Arbitrary instances for producing values with quickcheck
45 | instance Arbitrary InsertUser where
46 | arbitrary = genericArbitrarySingle
47 |
48 | sampleInsertUser :: InsertUser
49 | sampleInsertUser = InsertUser { userEmail = "mark@gmail.com"
50 | , userPassword = "MySecretPassword"
51 | , userFirstName = Just "Mark"
52 | , userBirthyear = Just 1980
53 | }
54 |
55 | data APIDBUser_ = APIDBUser_
56 | { userId :: UserId
57 | , email :: Text
58 | , first_name :: Maybe Text
59 | , birthyear :: Maybe Int16
60 | }
61 | deriving (Show, Eq, Generic, NFData)
62 | instance SOP.Generic APIDBUser_
63 | instance SOP.HasDatatypeInfo APIDBUser_
64 | -- Arbitrary instances for producing values with quickcheck
65 | instance Arbitrary APIDBUser_ where
66 | arbitrary = genericArbitrarySingle
67 |
68 | data Row3 a b c = Row4
69 | { col1 :: a
70 | , col2 :: b
71 | , col3 :: c
72 | }
73 | deriving stock Generic
74 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
75 |
76 | -- (UserId, Token, OS)
77 | type DeviceDetailsRow = Row3 UserId Text (Enumerated DeviceOS)
78 |
79 | -- -- Queries
80 |
81 | createUserSession :: InsertUser -> PQ Schemas Schemas IO APIDBUser_
82 | createUserSession insertUser =
83 | getRow 0 =<< manipulateParams createUser insertUser
84 |
85 | createUser :: Manipulation_ Schemas InsertUser APIDBUser_
86 | createUser = insertInto
87 | #users
88 | (Values_
89 | ( Default
90 | `as` #id
91 | :* Set (param @1)
92 | `as` #email
93 | :* Set (param @2)
94 | `as` #password
95 | :* Set (param @3)
96 | `as` #first_name
97 | :* Set (param @4 & cast int2)
98 | `as` #birthyear
99 | )
100 | )
101 | OnConflictDoRaise
102 | (Returning_
103 | ( #id
104 | `as` #userId
105 | :* #email
106 | `as` #email
107 | :* #first_name
108 | `as` #first_name
109 | :* #birthyear
110 | `as` #birthyear
111 | )
112 | )
113 |
114 | userDetailsSession :: UserId -> PQ Schemas Schemas IO APIDBUser_
115 | userDetailsSession uID = getRow 0 =<< runQueryParams userDetails (Only uID)
116 |
117 | userDetails :: Query_ Schemas (Only UserId) APIDBUser_
118 | userDetails = select_
119 | ( #id
120 | `as` #userId
121 | :* #email
122 | `as` #email
123 | :* #first_name
124 | `as` #first_name
125 | :* #birthyear
126 | `as` #birthyear
127 | )
128 | (from (table #users) & where_ (#id .== (param @1 & cast int8)))
129 |
130 | insertDeviceDetails :: Manipulation_ Schemas DeviceDetailsRow ()
131 | insertDeviceDetails = insertInto
132 | #user_devices
133 | (Values_
134 | ( Default
135 | `as` #id
136 | :* Set (param @1)
137 | `as` #user_id
138 | :* Set (param @2)
139 | `as` #token
140 | :* Set (parameter @3 (typedef #device_os))
141 | `as` #os
142 | )
143 | )
144 | OnConflictDoRaise
145 | (Returning_ Nil)
146 |
--------------------------------------------------------------------------------
/squeal-postgresql/bench/Gauge/Schema.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveGeneric #-}
2 | {-# LANGUAGE DataKinds #-}
3 | {-# LANGUAGE OverloadedLabels #-}
4 | {-# LANGUAGE FlexibleContexts #-}
5 | {-# LANGUAGE OverloadedStrings #-}
6 | {-# LANGUAGE TypeApplications #-}
7 | {-# LANGUAGE TypeOperators #-}
8 | {-# LANGUAGE GADTs #-}
9 | {-# LANGUAGE DeriveGeneric #-}
10 |
11 | module Gauge.Schema where
12 |
13 | import Squeal.PostgreSQL
14 | import GHC.Generics
15 | import qualified Generics.SOP as SOP
16 |
17 |
18 | -- Type
19 |
20 | data DeviceOS = Android | IOS
21 | deriving (Show, Read, Eq, Generic)
22 | -- DeviceOS is converted to PG Enum type
23 | instance SOP.Generic DeviceOS
24 | instance SOP.HasDatatypeInfo DeviceOS
25 |
26 | -- Defined extra types for the database
27 | -- Operating system enum
28 | type PGDeviceOS = PG (Enumerated DeviceOS)
29 | type DeviceOSType = 'Typedef PGDeviceOS
30 |
31 | -- For composite type
32 | data IPLocation = IPLocation
33 | { countryShort :: String
34 | , region :: String
35 | , city :: String
36 | }
37 | deriving (Show, Read, Eq, Generic)
38 |
39 | instance SOP.Generic IPLocation
40 | instance SOP.HasDatatypeInfo IPLocation
41 |
42 | -- IPLocation Composite type
43 | type PGIPLocation = PG (Composite IPLocation)
44 | type IPLocationType = 'Typedef PGIPLocation
45 |
46 | -- SCHEMA
47 |
48 | -- Users
49 |
50 | type UsersColumns = '[
51 | "id" ::: 'Def :=> 'NotNull 'PGint8
52 | , "email" ::: 'NoDef :=> 'NotNull 'PGtext
53 | , "password" ::: 'NoDef :=> 'NotNull 'PGtext
54 | , "first_name" ::: 'NoDef :=> 'Null 'PGtext
55 | , "birthyear" ::: 'NoDef :=> 'Null 'PGint2
56 | ]
57 |
58 | type UsersConstraints = '[
59 | "pk_users" ::: 'PrimaryKey '["id"]
60 | , "email" ::: 'Unique '["email"]
61 | ]
62 |
63 | type UsersTable = 'Table (UsersConstraints :=> UsersColumns)
64 |
65 | -- User devices
66 | type UserDevicesColumns = '[
67 | "id" ::: 'Def :=> 'NotNull 'PGint8 -- ID as PK because user might have many same OS devices
68 | , "user_id" ::: 'NoDef :=> 'NotNull 'PGint8
69 | , "token" ::: 'NoDef :=> 'NotNull 'PGtext
70 | , "os" ::: 'NoDef :=> 'NotNull PGDeviceOS
71 | ]
72 |
73 | type UserDevicesConstraints = '[
74 | "pk_user_devices" ::: 'PrimaryKey '["id"]
75 | , "fk_user_id" ::: 'ForeignKey '["user_id"] "public" "users" '["id"]
76 | , "token" ::: 'Unique '["token"]
77 | ]
78 |
79 | type UserDevicesTable = 'Table (UserDevicesConstraints :=> UserDevicesColumns)
80 |
81 | -- Schema
82 | -- Make sure to put types before tables, otherwise won't compile
83 | type Schema = '[
84 | -- Enum types:
85 | "device_os" ::: DeviceOSType
86 | -- Composite types:
87 | , "ip_location" ::: IPLocationType
88 | -- Tables:
89 | , "users" ::: UsersTable
90 | , "user_devices" ::: UserDevicesTable
91 | ]
92 |
93 | type Schemas = '["public" ::: Schema]
94 |
--------------------------------------------------------------------------------
/squeal-postgresql/bench/README.md:
--------------------------------------------------------------------------------
1 | # Microbenchark suite for Squeal
2 | > Benchmarking & profiling query rendering performance
3 |
4 | ## Running
5 |
6 | Run benchmark suite with:
7 | ```
8 | stack bench
9 | ```
10 |
--------------------------------------------------------------------------------
/squeal-postgresql/docs-upload.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | # Run this script in the top-level of your package directory
4 | # (where the .cabal file is) to compile documentation and
5 | # upload it to hackage.
6 |
7 | # Requirements:
8 | # cabal-install-1.24 (for --for-hackage)
9 | # haddock 2.17 (for the hyperlinked source)
10 |
11 | set -e
12 |
13 | dir=$(mktemp -d dist-docs.XXXXXX)
14 | trap 'rm -r "$dir"' EXIT
15 |
16 | cabal configure --builddir="$dir"
17 | cabal haddock --builddir="$dir" --for-hackage --haddock-option=--hyperlinked-source
18 | cabal upload -d $dir/*-docs.tar.gz
19 |
--------------------------------------------------------------------------------
/squeal-postgresql/squeal-postgresql.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.2
2 | name: squeal-postgresql
3 | version: 0.9.2.0
4 | synopsis: Squeal PostgreSQL Library
5 | description: Squeal is a type-safe embedding of PostgreSQL in Haskell
6 | homepage: https://github.com/morphismtech/squeal
7 | bug-reports: https://github.com/morphismtech/squeal/issues
8 | license: BSD-3-Clause
9 | license-file: LICENSE
10 | author: Eitan Chatav
11 | maintainer: eitan.chatav@gmail.com
12 | copyright: Copyright (c) 2022 Morphism, LLC
13 | category: Database
14 | build-type: Simple
15 | extra-doc-files: README.md
16 |
17 | source-repository head
18 | type: git
19 | location: https://github.com/morphismtech/squeal.git
20 |
21 | library
22 | hs-source-dirs: src
23 | exposed-modules:
24 | Squeal.PostgreSQL
25 | Squeal.PostgreSQL.Definition
26 | Squeal.PostgreSQL.Definition.Comment
27 | Squeal.PostgreSQL.Definition.Constraint
28 | Squeal.PostgreSQL.Definition.Function
29 | Squeal.PostgreSQL.Definition.Index
30 | Squeal.PostgreSQL.Definition.Table
31 | Squeal.PostgreSQL.Definition.Type
32 | Squeal.PostgreSQL.Definition.Procedure
33 | Squeal.PostgreSQL.Definition.Schema
34 | Squeal.PostgreSQL.Definition.View
35 | Squeal.PostgreSQL.Expression
36 | Squeal.PostgreSQL.Expression.Aggregate
37 | Squeal.PostgreSQL.Expression.Array
38 | Squeal.PostgreSQL.Expression.Comparison
39 | Squeal.PostgreSQL.Expression.Composite
40 | Squeal.PostgreSQL.Expression.Default
41 | Squeal.PostgreSQL.Expression.Json
42 | Squeal.PostgreSQL.Expression.Inline
43 | Squeal.PostgreSQL.Expression.Logic
44 | Squeal.PostgreSQL.Expression.Math
45 | Squeal.PostgreSQL.Expression.Null
46 | Squeal.PostgreSQL.Expression.Parameter
47 | Squeal.PostgreSQL.Expression.Range
48 | Squeal.PostgreSQL.Expression.Sort
49 | Squeal.PostgreSQL.Expression.Subquery
50 | Squeal.PostgreSQL.Expression.Text
51 | Squeal.PostgreSQL.Expression.TextSearch
52 | Squeal.PostgreSQL.Expression.Time
53 | Squeal.PostgreSQL.Expression.Type
54 | Squeal.PostgreSQL.Expression.Window
55 | Squeal.PostgreSQL.Manipulation
56 | Squeal.PostgreSQL.Manipulation.Call
57 | Squeal.PostgreSQL.Manipulation.Delete
58 | Squeal.PostgreSQL.Manipulation.Insert
59 | Squeal.PostgreSQL.Manipulation.Update
60 | Squeal.PostgreSQL.Render
61 | Squeal.PostgreSQL.Query
62 | Squeal.PostgreSQL.Query.From
63 | Squeal.PostgreSQL.Query.From.Join
64 | Squeal.PostgreSQL.Query.From.Set
65 | Squeal.PostgreSQL.Query.Select
66 | Squeal.PostgreSQL.Query.Table
67 | Squeal.PostgreSQL.Query.Values
68 | Squeal.PostgreSQL.Query.With
69 | Squeal.PostgreSQL.Session
70 | Squeal.PostgreSQL.Session.Connection
71 | Squeal.PostgreSQL.Session.Decode
72 | Squeal.PostgreSQL.Session.Encode
73 | Squeal.PostgreSQL.Session.Exception
74 | Squeal.PostgreSQL.Session.Indexed
75 | Squeal.PostgreSQL.Session.Migration
76 | Squeal.PostgreSQL.Session.Monad
77 | Squeal.PostgreSQL.Session.Oid
78 | Squeal.PostgreSQL.Session.Pool
79 | Squeal.PostgreSQL.Session.Result
80 | Squeal.PostgreSQL.Session.Statement
81 | Squeal.PostgreSQL.Session.Transaction
82 | Squeal.PostgreSQL.Session.Transaction.Unsafe
83 | Squeal.PostgreSQL.Type
84 | Squeal.PostgreSQL.Type.Alias
85 | Squeal.PostgreSQL.Type.List
86 | Squeal.PostgreSQL.Type.PG
87 | Squeal.PostgreSQL.Type.Schema
88 | default-language: Haskell2010
89 | ghc-options: -Wall
90 | build-depends:
91 | aeson >= 1.4.7.1
92 | , base >= 4.12.0.0 && < 5.0
93 | , binary >= 0.8.7.0
94 | , binary-parser >= 0.5.5
95 | , bytestring >= 0.10.10.0
96 | , bytestring-strict-builder >= 0.4.5.3
97 | , deepseq >= 1.4.4.0
98 | , exceptions >= 0.10.3
99 | , free-categories >= 0.2.0.0
100 | , generics-sop >= 0.5.1.0
101 | , hashable >= 1.3.0.0
102 | , iproute >= 1.7.0
103 | , mmorph >= 1.1.3
104 | , monad-control >= 1.0.2.3
105 | , mtl >= 2.2.2
106 | , network-ip >= 0.3.0.3
107 | , postgresql-binary >= 0.12.2
108 | , postgresql-libpq >= 0.9.4.2
109 | , profunctors >= 5.5.2
110 | , records-sop >= 0.1.0.3
111 | , resource-pool >= 0.2.3.2
112 | , scientific >= 0.3.6.2
113 | , text >= 1.2.3.2
114 | , time >= 1.9.3
115 | , transformers >= 0.5.6.2
116 | , transformers-base >= 0.4.5.2
117 | , unliftio >= 0.2.12.1
118 | , uuid-types >= 1.0.3
119 | , vector >= 0.12.1.2
120 |
121 | test-suite doctest
122 | default-language: Haskell2010
123 | type: exitcode-stdio-1.0
124 | hs-source-dirs: test
125 | ghc-options: -Wall
126 | main-is: Doc.hs
127 | build-depends:
128 | base >= 4.12.0.0 && < 5.0
129 | , doctest >= 0.16.3
130 | if impl(ghc >= 9.0.0)
131 | buildable: False
132 |
133 | test-suite properties
134 | default-language: Haskell2010
135 | type: exitcode-stdio-1.0
136 | hs-source-dirs: test
137 | ghc-options: -Wall
138 | main-is: Property.hs
139 | build-depends:
140 | base >= 4.12.0.0 && < 5.0
141 | , bytestring >= 0.10.10.0
142 | , hedgehog >= 1.0.2
143 | , generics-sop >= 0.5.1.0
144 | , mtl >= 2.2.2
145 | , scientific >= 0.3.6.2
146 | , squeal-postgresql
147 | , time >= 1.9.3
148 | , with-utf8 >= 1.0
149 |
150 | test-suite spec
151 | default-language: Haskell2010
152 | type: exitcode-stdio-1.0
153 | hs-source-dirs: test
154 | ghc-options: -Wall
155 | main-is: Spec.hs
156 | build-depends:
157 | async >= 2.2.2
158 | , base >= 4.12.0.0 && < 5.0
159 | , bytestring >= 0.10.10.0
160 | , generics-sop >= 0.5.1.0
161 | , hspec >= 2.7.1
162 | , mtl >= 2.2.2
163 | , squeal-postgresql
164 | , text >= 1.2.3.2
165 | , vector >= 0.12.1.2
166 |
167 | benchmark gauge
168 | type: exitcode-stdio-1.0
169 | hs-source-dirs: bench
170 | main-is: Gauge.hs
171 | other-modules:
172 | Gauge.DBHelpers
173 | , Gauge.DBSetup
174 | , Gauge.Queries
175 | , Gauge.Schema
176 | default-language: Haskell2010
177 | ghc-options:
178 | -O2
179 | -threaded
180 | "-with-rtsopts=-N"
181 | -rtsopts
182 | -funbox-strict-fields
183 | build-depends:
184 | base >= 4.12.0.0 && < 5.0
185 | , bytestring >= 0.10.10.0
186 | , deepseq >= 1.4.4.0
187 | , gauge >= 0.2.5
188 | , generic-random >= 1.3.0.1
189 | , generics-sop >= 0.5.1.0
190 | , monad-loops >= 0.4.3
191 | , mtl >= 2.2.2
192 | , QuickCheck >= 2.13.2
193 | , quickcheck-instances >= 0.3.22
194 | , scientific >= 0.3.6.2
195 | , squeal-postgresql
196 | , text >= 1.2.3.2
197 | , with-utf8 >= 1.0
198 |
199 | executable example
200 | default-language: Haskell2010
201 | hs-source-dirs: exe
202 | ghc-options: -Wall
203 | main-is: Example.hs
204 | build-depends:
205 | base >= 4.10.0.0 && < 5.0
206 | , bytestring >= 0.10.10.0
207 | , generics-sop >= 0.5.1.0
208 | , mtl >= 2.2.2
209 | , squeal-postgresql
210 | , text >= 1.2.3.2
211 | , transformers >= 0.5.6.2
212 | , vector >= 0.12.1.2
213 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Definition.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Definition
3 | Description: data definition language
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | data definition language
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DerivingStrategies
17 | , FlexibleContexts
18 | , FlexibleInstances
19 | , GADTs
20 | , LambdaCase
21 | , MultiParamTypeClasses
22 | , OverloadedLabels
23 | , OverloadedStrings
24 | , RankNTypes
25 | , ScopedTypeVariables
26 | , TypeApplications
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableSuperClasses
31 | , UndecidableInstances
32 | #-}
33 |
34 | module Squeal.PostgreSQL.Definition
35 | ( -- * Definition
36 | Definition (..)
37 | , (>>>)
38 | , manipulation_
39 | ) where
40 |
41 | import Control.Category
42 | import Control.DeepSeq
43 | import Data.ByteString
44 | import Data.Monoid
45 | import Prelude hiding ((.), id)
46 |
47 | import qualified GHC.Generics as GHC
48 |
49 | import Squeal.PostgreSQL.Manipulation
50 | import Squeal.PostgreSQL.Render
51 | import Squeal.PostgreSQL.Type.Schema
52 |
53 | -- $setup
54 | -- >>> import Squeal.PostgreSQL
55 |
56 | {-----------------------------------------
57 | statements
58 | -----------------------------------------}
59 |
60 | -- | A `Definition` is a statement that changes the schemas of the
61 | -- database, like a `Squeal.PostgreSQL.Definition.Table.createTable`,
62 | -- `Squeal.PostgreSQL.Definition.Table.dropTable`,
63 | -- or `Squeal.PostgreSQL.Definition.Table.alterTable` command.
64 | -- `Definition`s may be composed using the `>>>` operator.
65 | newtype Definition
66 | (db0 :: SchemasType)
67 | (db1 :: SchemasType)
68 | = UnsafeDefinition { renderDefinition :: ByteString }
69 | deriving (GHC.Generic,Show,Eq,Ord,NFData)
70 |
71 | instance RenderSQL (Definition db0 db1) where
72 | renderSQL = renderDefinition
73 |
74 | instance Category Definition where
75 | id = UnsafeDefinition ";"
76 | ddl1 . ddl0 = UnsafeDefinition $
77 | renderSQL ddl0 <> "\n" <> renderSQL ddl1
78 |
79 | instance db0 ~ db1 => Semigroup (Definition db0 db1) where (<>) = (>>>)
80 | instance db0 ~ db1 => Monoid (Definition db0 db1) where mempty = id
81 |
82 | -- | A `Manipulation` without input or output can be run as a statement
83 | -- along with other `Definition`s, by embedding it using `manipulation_`.
84 | manipulation_
85 | :: Manipulation '[] db '[] '[]
86 | -- ^ no input or output
87 | -> Definition db db
88 | manipulation_ = UnsafeDefinition . (<> ";") . renderSQL
89 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Comment.hs:
--------------------------------------------------------------------------------
1 | {- |
2 | Module: Squeal.PostgreSQL.Definition.Constraint
3 | Description: comments
4 | Copyright: (c) Eitan Chatav, 2020
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | comments
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DerivingStrategies
17 | , FlexibleContexts
18 | , FlexibleInstances
19 | , GADTs
20 | , LambdaCase
21 | , MultiParamTypeClasses
22 | , OverloadedLabels
23 | , OverloadedStrings
24 | , RankNTypes
25 | , ScopedTypeVariables
26 | , TypeApplications
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableSuperClasses
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Definition.Comment
34 | ( commentOnTable
35 | , commentOnType
36 | , commentOnView
37 | , commentOnFunction
38 | , commentOnIndex
39 | , commentOnColumn
40 | , commentOnSchema
41 | ) where
42 |
43 | import Squeal.PostgreSQL.Definition
44 | import Squeal.PostgreSQL.Type.Alias
45 | import Squeal.PostgreSQL.Render
46 | import Squeal.PostgreSQL.Type.Schema
47 | import GHC.TypeLits (KnownSymbol)
48 | import Data.Text (Text)
49 |
50 | {-----------------------------------------
51 | COMMENT statements
52 | -----------------------------------------}
53 |
54 | {- |
55 | When a user views a table in the database (i.e. with \d+
), it is useful
56 | to be able to read a description of the table.
57 | -}
58 | commentOnTable
59 | :: ( KnownSymbol sch
60 | , KnownSymbol tab
61 | , Has sch db schema
62 | , Has tab schema ('Table table)
63 | )
64 | => QualifiedAlias sch tab -- ^ table
65 | -> Text -- ^ comment
66 | -> Definition db db
67 | commentOnTable alias comm = UnsafeDefinition $
68 | "COMMENT ON TABLE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"
69 |
70 | {- |
71 | When a user views a type in the database (i.e with \dT ), it is useful to
72 | be able to read a description of the type.
73 | -}
74 | commentOnType
75 | :: ( KnownSymbol sch
76 | , KnownSymbol typ
77 | , Has sch db schema
78 | , Has typ schema ('Typedef type_)
79 | )
80 | => QualifiedAlias sch typ -- ^ type
81 | -> Text -- ^ comment
82 | -> Definition db db
83 | commentOnType alias comm = UnsafeDefinition $
84 | "COMMENT ON TYPE" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"
85 |
86 | {- |
87 | When a user views a view in the database (i.e. with \dv ), it is useful
88 | to be able to read a description of the view.
89 | -}
90 | commentOnView
91 | :: ( KnownSymbol sch
92 | , KnownSymbol vie
93 | , Has sch db schema
94 | , Has vie schema ('View view)
95 | )
96 | => QualifiedAlias sch vie -- ^ view
97 | -> Text -- ^ comment
98 | -> Definition db db
99 | commentOnView alias comm = UnsafeDefinition $
100 | "COMMENT ON VIEW" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"
101 |
102 | {- |
103 | When a user views an index in the database (i.e. with \di+ ), it is
104 | useful to be able to read a description of the index.
105 | -}
106 | commentOnIndex
107 | :: ( KnownSymbol sch
108 | , KnownSymbol ind
109 | , Has sch db schema
110 | , Has ind schema ('Index index)
111 | )
112 | => QualifiedAlias sch ind -- ^ index
113 | -> Text -- ^ comment
114 | -> Definition db db
115 | commentOnIndex alias comm = UnsafeDefinition $
116 | "COMMENT ON INDEX" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"
117 |
118 | {- |
119 | When a user views a function in the database (i.e. with \df+ ), it is
120 | useful to be able to read a description of the function.
121 | -}
122 | commentOnFunction
123 | :: ( KnownSymbol sch
124 | , KnownSymbol fun
125 | , Has sch db schema
126 | , Has fun schema ('Function function)
127 | )
128 | => QualifiedAlias sch fun -- ^ function
129 | -> Text -- ^ comment
130 | -> Definition db db
131 | commentOnFunction alias comm = UnsafeDefinition $
132 | "COMMENT ON FUNCTION" <+> renderSQL alias <+> "IS" <+> singleQuotedText comm <> ";"
133 |
134 | {- |
135 | When a user views a table in the database (i.e. with \d+ ), it is useful
136 | to be able to view descriptions of the columns in that table.
137 | -}
138 | commentOnColumn
139 | :: ( KnownSymbol sch
140 | , KnownSymbol tab
141 | , KnownSymbol col
142 | , Has sch db schema
143 | , Has tab schema ('Table '(cons, cols))
144 | , Has col cols '(def, nulltyp)
145 | )
146 | => QualifiedAlias sch tab -- ^ table
147 | -> Alias col -- ^ column
148 | -> Text -- ^ comment
149 | -> Definition db db
150 | commentOnColumn table col comm = UnsafeDefinition $
151 | "COMMENT ON COLUMN" <+> renderSQL table <> "." <> renderSQL col <+> "IS"
152 | <+> singleQuotedText comm <> ";"
153 |
154 | {- |
155 | When a user views a schema in the database (i.e. with \dn+ ), it is
156 | useful to be able to read a description.
157 | -}
158 | commentOnSchema
159 | :: ( KnownSymbol sch
160 | , Has sch db schema
161 | )
162 | => Alias sch -- ^ schema
163 | -> Text -- ^ comment
164 | -> Definition db db
165 | commentOnSchema schema comm = UnsafeDefinition $
166 | "COMMENT ON SCHEMA" <+> renderSQL schema <> "IS" <+> singleQuotedText comm <> ";"
167 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Index.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Definition.Index
3 | Description: create and drop indexes
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | create and drop indexes
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DerivingStrategies
17 | , FlexibleContexts
18 | , FlexibleInstances
19 | , GADTs
20 | , LambdaCase
21 | , MultiParamTypeClasses
22 | , OverloadedLabels
23 | , OverloadedStrings
24 | , RankNTypes
25 | , ScopedTypeVariables
26 | , TypeApplications
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableSuperClasses
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Definition.Index
34 | ( -- * Create
35 | createIndex
36 | , createIndexIfNotExists
37 | -- * Drop
38 | , dropIndex
39 | , dropIndexIfExists
40 | -- * Index Method
41 | , IndexMethod (..)
42 | , btree
43 | , hash
44 | , gist
45 | , spgist
46 | , gin
47 | , brin
48 | ) where
49 |
50 | import Data.ByteString
51 | import GHC.TypeLits
52 |
53 | import qualified GHC.Generics as GHC
54 |
55 | import Squeal.PostgreSQL.Type.Alias
56 | import Squeal.PostgreSQL.Definition
57 | import Squeal.PostgreSQL.Expression.Sort
58 | import Squeal.PostgreSQL.Render
59 | import Squeal.PostgreSQL.Type.Schema
60 |
61 | -- $setup
62 | -- >>> import Squeal.PostgreSQL
63 | -- >>> :set -XPolyKinds
64 |
65 | {- | Create an index.
66 |
67 | >>> :{
68 | type Table = '[] :=>
69 | '[ "a" ::: 'NoDef :=> 'Null 'PGint4
70 | , "b" ::: 'NoDef :=> 'Null 'PGfloat4 ]
71 | :}
72 |
73 | >>> :{
74 | let
75 | setup :: Definition (Public '[]) (Public '["tab" ::: 'Table Table, "ix" ::: 'Index 'Btree])
76 | setup =
77 | createTable #tab (nullable int `as` #a :* nullable real `as` #b) Nil >>>
78 | createIndex #ix #tab btree [#a & AscNullsFirst, #b & AscNullsLast]
79 | in printSQL setup
80 | :}
81 | CREATE TABLE "tab" ("a" int NULL, "b" real NULL);
82 | CREATE INDEX "ix" ON "tab" USING btree (("a") ASC NULLS FIRST, ("b") ASC NULLS LAST);
83 | -}
84 | createIndex
85 | :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix)
86 | => Alias ix -- ^ index alias
87 | -> QualifiedAlias sch tab -- ^ table alias
88 | -> IndexMethod method -- ^ index method
89 | -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]]
90 | -- ^ sorted columns
91 | -> Definition db (Alter sch (Create ix ('Index method) schema) db)
92 | createIndex ix tab method cols = UnsafeDefinition $
93 | "CREATE" <+> "INDEX" <+> renderSQL ix <+> "ON" <+> renderSQL tab
94 | <+> "USING" <+> renderSQL method
95 | <+> parenthesized (commaSeparated (renderIndex <$> cols))
96 | <> ";"
97 | where
98 | renderIndex = \case
99 | Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
100 | Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
101 | AscNullsFirst expression -> parenthesized (renderSQL expression)
102 | <+> "ASC NULLS FIRST"
103 | DescNullsFirst expression -> parenthesized (renderSQL expression)
104 | <+> "DESC NULLS FIRST"
105 | AscNullsLast expression -> parenthesized (renderSQL expression)
106 | <+> "ASC NULLS LAST"
107 | DescNullsLast expression -> parenthesized (renderSQL expression)
108 | <+> "DESC NULLS LAST"
109 |
110 | -- | Create an index if it doesn't exist.
111 | createIndexIfNotExists
112 | :: (Has sch db schema, Has tab schema ('Table table), KnownSymbol ix)
113 | => Alias ix -- ^ index alias
114 | -> QualifiedAlias sch tab -- ^ table alias
115 | -> IndexMethod method -- ^ index method
116 | -> [SortExpression 'Ungrouped '[] '[] db '[] '[tab ::: TableToRow table]]
117 | -- ^ sorted columns
118 | -> Definition db (Alter sch (CreateIfNotExists ix ('Index method) schema) db)
119 | createIndexIfNotExists ix tab method cols = UnsafeDefinition $
120 | "CREATE INDEX IF NOT EXISTS" <+> renderSQL ix <+> "ON" <+> renderSQL tab
121 | <+> "USING" <+> renderSQL method
122 | <+> parenthesized (commaSeparated (renderIndex <$> cols))
123 | <> ";"
124 | where
125 | renderIndex = \case
126 | Asc expression -> parenthesized (renderSQL expression) <+> "ASC"
127 | Desc expression -> parenthesized (renderSQL expression) <+> "DESC"
128 | AscNullsFirst expression -> parenthesized (renderSQL expression)
129 | <+> "ASC NULLS FIRST"
130 | DescNullsFirst expression -> parenthesized (renderSQL expression)
131 | <+> "DESC NULLS FIRST"
132 | AscNullsLast expression -> parenthesized (renderSQL expression)
133 | <+> "ASC NULLS LAST"
134 | DescNullsLast expression -> parenthesized (renderSQL expression)
135 | <+> "DESC NULLS LAST"
136 |
137 | {- |
138 | PostgreSQL provides several index types:
139 | B-tree, Hash, GiST, SP-GiST, GIN and BRIN.
140 | Each index type uses a different algorithm
141 | that is best suited to different types of queries.
142 | -}
143 | newtype IndexMethod ty = UnsafeIndexMethod {renderIndexMethod :: ByteString}
144 | deriving stock (Eq, Ord, Show, GHC.Generic)
145 | instance RenderSQL (IndexMethod ty) where renderSQL = renderIndexMethod
146 | -- | B-trees can handle equality and range queries on data
147 | -- that can be sorted into some ordering.
148 | btree :: IndexMethod 'Btree
149 | btree = UnsafeIndexMethod "btree"
150 | -- | Hash indexes can only handle simple equality comparisons.
151 | hash :: IndexMethod 'Hash
152 | hash = UnsafeIndexMethod "hash"
153 | -- | GiST indexes are not a single kind of index,
154 | -- but rather an infrastructure within which many different
155 | -- indexing strategies can be implemented.
156 | gist :: IndexMethod 'Gist
157 | gist = UnsafeIndexMethod "gist"
158 | -- | SP-GiST indexes, like GiST indexes,
159 | -- offer an infrastructure that supports various kinds of searches.
160 | spgist :: IndexMethod 'Spgist
161 | spgist = UnsafeIndexMethod "spgist"
162 | -- | GIN indexes are “inverted indexes” which are appropriate for
163 | -- data values that contain multiple component values, such as arrays.
164 | gin :: IndexMethod 'Gin
165 | gin = UnsafeIndexMethod "gin"
166 | -- | BRIN indexes (a shorthand for Block Range INdexes) store summaries
167 | -- about the values stored in consecutive physical block ranges of a table.
168 | brin :: IndexMethod 'Brin
169 | brin = UnsafeIndexMethod "brin"
170 |
171 | -- | Drop an index.
172 | --
173 | -- >>> printSQL (dropIndex #ix :: Definition (Public '["ix" ::: 'Index 'Btree]) (Public '[]))
174 | -- DROP INDEX "ix";
175 | dropIndex
176 | :: (Has sch db schema, KnownSymbol ix)
177 | => QualifiedAlias sch ix -- ^ index alias
178 | -> Definition db (Alter sch (DropSchemum ix 'Index schema) db)
179 | dropIndex ix = UnsafeDefinition $ "DROP INDEX" <+> renderSQL ix <> ";"
180 |
181 | -- | Drop an index if it exists.
182 | dropIndexIfExists
183 | :: (Has sch db schema, KnownSymbol ix)
184 | => QualifiedAlias sch ix -- ^ index alias
185 | -> Definition db (Alter sch (DropSchemumIfExists ix 'Index schema) db)
186 | dropIndexIfExists ix = UnsafeDefinition $
187 | "DROP INDEX IF EXISTS" <+> renderSQL ix <> ";"
188 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Procedure.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Definition.Procedure
3 | Description: create and drop procedures
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | create and drop procedures
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DerivingStrategies
17 | , FlexibleContexts
18 | , FlexibleInstances
19 | , GADTs
20 | , LambdaCase
21 | , MultiParamTypeClasses
22 | , OverloadedLabels
23 | , OverloadedStrings
24 | , RankNTypes
25 | , ScopedTypeVariables
26 | , TypeApplications
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableSuperClasses
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Definition.Procedure
34 | ( -- * Create
35 | createProcedure
36 | , createOrReplaceProcedure
37 | -- * Drop
38 | , dropProcedure
39 | , dropProcedureIfExists
40 | -- * Procedure Definition
41 | , ProcedureDefinition(..)
42 | , languageSqlManipulation
43 | ) where
44 |
45 | import Control.DeepSeq
46 | import Data.ByteString
47 | import GHC.TypeLits
48 |
49 | import qualified Generics.SOP as SOP
50 | import qualified GHC.Generics as GHC
51 |
52 | import Squeal.PostgreSQL.Type.Alias
53 | import Squeal.PostgreSQL.Definition
54 | import Squeal.PostgreSQL.Expression.Type
55 | import Squeal.PostgreSQL.Type.List
56 | import Squeal.PostgreSQL.Manipulation
57 | import Squeal.PostgreSQL.Render
58 | import Squeal.PostgreSQL.Type.Schema
59 |
60 | -- $setup
61 | -- >>> import Squeal.PostgreSQL
62 |
63 | {- | Create a procedure.
64 |
65 | >>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ]
66 | >>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ])
67 | >>> :{
68 | let
69 | definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc])
70 | definition = createProcedure #proc (one int4)
71 | . languageSqlManipulation
72 | $ [deleteFrom_ #things (#id .== param @1)]
73 | in printSQL definition
74 | :}
75 | CREATE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$;
76 | -}
77 | createProcedure
78 | :: ( Has sch db schema
79 | , KnownSymbol pro
80 | , SOP.SListI args )
81 | => QualifiedAlias sch pro -- ^ procedure alias
82 | -> NP (TypeExpression db) args -- ^ arguments
83 | -> ProcedureDefinition db args -- ^ procedure definition
84 | -> Definition db (Alter sch (Create pro ('Procedure args) schema) db)
85 | createProcedure pro args prodef = UnsafeDefinition $
86 | "CREATE" <+> "PROCEDURE" <+> renderSQL pro
87 | <+> parenthesized (renderCommaSeparated renderSQL args)
88 | <+> renderSQL prodef <> ";"
89 |
90 | {- | Create or replace a procedure.
91 | It is not possible to change the name or argument types
92 | of a procedure this way.
93 |
94 | >>> type Proc = 'Procedure '[ 'NotNull 'PGint4 ]
95 | >>> type Thing = 'Table ('[] :=> '[ "id" ::: 'NoDef :=> 'NotNull 'PGint4 ])
96 | >>> :{
97 | let
98 | definition :: Definition (Public '["things" ::: Thing ]) (Public '["things" ::: Thing, "proc" ::: Proc])
99 | definition = createOrReplaceProcedure #proc (one int4)
100 | . languageSqlManipulation
101 | $ [deleteFrom_ #things (#id .== param @1)]
102 | in printSQL definition
103 | :}
104 | CREATE OR REPLACE PROCEDURE "proc" (int4) language sql as $$ DELETE FROM "things" AS "things" WHERE ("id" = ($1 :: int4)); $$;
105 | -}
106 | createOrReplaceProcedure
107 | :: ( Has sch db schema
108 | , KnownSymbol pro
109 | , SOP.SListI args )
110 | => QualifiedAlias sch pro -- ^ procedure alias
111 | -> NP (TypeExpression db) args -- ^ arguments
112 | -> ProcedureDefinition db args -- ^ procedure definition
113 | -> Definition db (Alter sch (CreateOrReplace pro ('Procedure args) schema) db)
114 | createOrReplaceProcedure pro args prodef = UnsafeDefinition $
115 | "CREATE" <+> "OR" <+> "REPLACE" <+> "PROCEDURE" <+> renderSQL pro
116 | <+> parenthesized (renderCommaSeparated renderSQL args)
117 | <+> renderSQL prodef <> ";"
118 |
119 | -- | Use a parameterized `Manipulation` as a procedure body
120 | languageSqlManipulation
121 | :: [Manipulation '[] db args '[]]
122 | -- ^ procedure body
123 | -> ProcedureDefinition db args
124 | languageSqlManipulation mnps = UnsafeProcedureDefinition $
125 | "language sql as" <+> "$$" <+> Prelude.foldr (<+>) "" (Prelude.map ((<> ";") . renderSQL) mnps) <> "$$"
126 |
127 | -- |
128 |
129 | {- | Drop a procedure.
130 |
131 | >>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4]
132 | >>> :{
133 | let
134 | definition :: Definition (Public '["proc" ::: Proc]) (Public '[])
135 | definition = dropProcedure #proc
136 | in printSQL definition
137 | :}
138 | DROP PROCEDURE "proc";
139 | -}
140 | dropProcedure
141 | :: (Has sch db schema, KnownSymbol pro)
142 | => QualifiedAlias sch pro
143 | -- ^ procedure alias
144 | -> Definition db (Alter sch (DropSchemum pro 'Procedure schema) db)
145 | dropProcedure pro = UnsafeDefinition $
146 | "DROP PROCEDURE" <+> renderSQL pro <> ";"
147 |
148 | {- | Drop a procedure.
149 |
150 | >>> type Proc = 'Procedure '[ 'Null 'PGint4, 'Null 'PGint4 ]
151 | >>> :{
152 | let
153 | definition :: Definition (Public '[]) (Public '[])
154 | definition = dropProcedureIfExists #proc
155 | in printSQL definition
156 | :}
157 | DROP PROCEDURE IF EXISTS "proc";
158 | -}
159 | dropProcedureIfExists
160 | :: (Has sch db schema, KnownSymbol pro)
161 | => QualifiedAlias sch pro
162 | -- ^ procedure alias
163 | -> Definition db (Alter sch (DropSchemumIfExists pro 'Procedure schema) db)
164 | dropProcedureIfExists pro = UnsafeDefinition $
165 | "DROP PROCEDURE IF EXISTS" <+> renderSQL pro <> ";"
166 |
167 | {- | Body of a user defined procedure-}
168 | newtype ProcedureDefinition db args = UnsafeProcedureDefinition
169 | { renderProcedureDefinition :: ByteString }
170 | deriving (Eq,Show,GHC.Generic,NFData)
171 | instance RenderSQL (ProcedureDefinition db args) where
172 | renderSQL = renderProcedureDefinition
173 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Definition/Schema.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Definition.Schema
3 | Description: create and drop schemas
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | create and drop schemas
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DerivingStrategies
17 | , FlexibleContexts
18 | , FlexibleInstances
19 | , GADTs
20 | , LambdaCase
21 | , MultiParamTypeClasses
22 | , OverloadedLabels
23 | , OverloadedStrings
24 | , RankNTypes
25 | , ScopedTypeVariables
26 | , TypeApplications
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableSuperClasses
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Definition.Schema
34 | ( -- * Create
35 | createSchema
36 | , createSchemaIfNotExists
37 | -- * Drop
38 | , dropSchemaCascade
39 | , dropSchemaCascadeIfExists
40 | ) where
41 |
42 | import GHC.TypeLits
43 |
44 | import Squeal.PostgreSQL.Type.Alias
45 | import Squeal.PostgreSQL.Definition
46 | import Squeal.PostgreSQL.Render
47 | import Squeal.PostgreSQL.Type.Schema
48 |
49 | -- $setup
50 | -- >>> import Squeal.PostgreSQL
51 |
52 | {- |
53 | `createSchema` enters a new schema into the current database.
54 | The schema name must be distinct from the name of any existing schema
55 | in the current database.
56 |
57 | A schema is essentially a namespace: it contains named objects
58 | (tables, data types, functions, and operators) whose names
59 | can duplicate those of other objects existing in other schemas.
60 | Named objects are accessed by `QualifiedAlias`es with the schema
61 | name as a prefix.
62 |
63 | >>> :{
64 | let
65 | definition :: Definition '["public" ::: '[]] '["public" ::: '[], "my_schema" ::: '[]]
66 | definition = createSchema #my_schema
67 | in printSQL definition
68 | :}
69 | CREATE SCHEMA "my_schema";
70 | -}
71 | createSchema
72 | :: KnownSymbol sch
73 | => Alias sch -- ^ schema alias
74 | -> Definition db (Create sch '[] db)
75 | createSchema sch = UnsafeDefinition $
76 | "CREATE" <+> "SCHEMA" <+> renderSQL sch <> ";"
77 |
78 | {- | Create a schema if it does not yet exist.-}
79 | createSchemaIfNotExists
80 | :: (KnownSymbol sch, Has sch db schema)
81 | => Alias sch -- ^ schema alias
82 | -> Definition db (CreateIfNotExists sch '[] db)
83 | createSchemaIfNotExists sch = UnsafeDefinition $
84 | "CREATE" <+> "SCHEMA" <+> "IF" <+> "NOT" <+> "EXISTS"
85 | <+> renderSQL sch <> ";"
86 |
87 | -- | Drop a schema.
88 | -- Automatically drop objects (tables, functions, etc.)
89 | -- that are contained in the schema.
90 | --
91 | -- >>> :{
92 | -- let
93 | -- definition :: Definition '["muh_schema" ::: schema, "public" ::: public] '["public" ::: public]
94 | -- definition = dropSchemaCascade #muh_schema
95 | -- :}
96 | --
97 | -- >>> printSQL definition
98 | -- DROP SCHEMA "muh_schema" CASCADE;
99 | dropSchemaCascade
100 | :: KnownSymbol sch
101 | => Alias sch -- ^ schema alias
102 | -> Definition db (Drop sch db)
103 | dropSchemaCascade sch = UnsafeDefinition $
104 | "DROP SCHEMA" <+> renderSQL sch <+> "CASCADE;"
105 |
106 | -- | Drop a schema if it exists.
107 | -- Automatically drop objects (tables, functions, etc.)
108 | -- that are contained in the schema.
109 | dropSchemaCascadeIfExists
110 | :: KnownSymbol sch
111 | => Alias sch -- ^ schema alias
112 | -> Definition db (DropIfExists sch db)
113 | dropSchemaCascadeIfExists sch = UnsafeDefinition $
114 | "DROP SCHEMA IF EXISTS" <+> renderSQL sch <+> "CASCADE;"
115 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Definition/View.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Definition.View
3 | Description: create and drop views
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | create and drop views
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DerivingStrategies
17 | , FlexibleContexts
18 | , FlexibleInstances
19 | , GADTs
20 | , LambdaCase
21 | , MultiParamTypeClasses
22 | , OverloadedLabels
23 | , OverloadedStrings
24 | , RankNTypes
25 | , ScopedTypeVariables
26 | , TypeApplications
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableSuperClasses
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Definition.View
34 | ( -- * Create
35 | createView
36 | , createOrReplaceView
37 | -- * Drop
38 | , dropView
39 | , dropViewIfExists
40 | -- * Alter
41 | , alterViewRename
42 | , alterViewSetSchema
43 | ) where
44 |
45 | import GHC.TypeLits
46 |
47 | import Squeal.PostgreSQL.Type.Alias
48 | import Squeal.PostgreSQL.Definition
49 | import Squeal.PostgreSQL.Query
50 | import Squeal.PostgreSQL.Render
51 | import Squeal.PostgreSQL.Type.Schema
52 |
53 | -- $setup
54 | -- >>> import Squeal.PostgreSQL
55 |
56 | {- | Create a view.
57 |
58 | >>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
59 | >>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
60 | >>> :{
61 | let
62 | definition :: Definition
63 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
64 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
65 | definition =
66 | createView #bc (select_ (#b :* #c) (from (table #abc)))
67 | in printSQL definition
68 | :}
69 | CREATE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
70 | -}
71 | createView
72 | :: (Has sch db schema, KnownSymbol vw)
73 | => QualifiedAlias sch vw -- ^ the name of the view to add
74 | -> Query '[] '[] db '[] view -- ^ query
75 | -> Definition db (Alter sch (Create vw ('View view) schema) db)
76 | createView alias query = UnsafeDefinition $
77 | "CREATE" <+> "VIEW" <+> renderSQL alias <+> "AS"
78 | <+> renderQuery query <> ";"
79 |
80 | {- | Create or replace a view.
81 |
82 | >>> type ABC = '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4]
83 | >>> type BC = '["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4]
84 | >>> :{
85 | let
86 | definition :: Definition
87 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC)]]
88 | '[ "public" ::: '["abc" ::: 'Table ('[] :=> ABC), "bc" ::: 'View BC]]
89 | definition =
90 | createOrReplaceView #bc (select_ (#b :* #c) (from (table #abc)))
91 | in printSQL definition
92 | :}
93 | CREATE OR REPLACE VIEW "bc" AS SELECT "b" AS "b", "c" AS "c" FROM "abc" AS "abc";
94 | -}
95 | createOrReplaceView
96 | :: (Has sch db schema, KnownSymbol vw)
97 | => QualifiedAlias sch vw -- ^ the name of the view to add
98 | -> Query '[] '[] db '[] view -- ^ query
99 | -> Definition db (Alter sch (CreateOrReplace vw ('View view) schema) db)
100 | createOrReplaceView alias query = UnsafeDefinition $
101 | "CREATE OR REPLACE VIEW" <+> renderSQL alias <+> "AS"
102 | <+> renderQuery query <> ";"
103 |
104 | -- | Drop a view.
105 | --
106 | -- >>> :{
107 | -- let
108 | -- definition :: Definition
109 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
110 | -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
111 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
112 | -- definition = dropView #bc
113 | -- in printSQL definition
114 | -- :}
115 | -- DROP VIEW "bc";
116 | dropView
117 | :: (Has sch db schema, KnownSymbol vw)
118 | => QualifiedAlias sch vw -- ^ view to remove
119 | -> Definition db (Alter sch (DropSchemum vw 'View schema) db)
120 | dropView vw = UnsafeDefinition $ "DROP VIEW" <+> renderSQL vw <> ";"
121 |
122 | -- | Drop a view if it exists.
123 | --
124 | -- >>> :{
125 | -- let
126 | -- definition :: Definition
127 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])
128 | -- , "bc" ::: 'View ('["b" ::: 'Null 'PGint4, "c" ::: 'Null 'PGint4])]]
129 | -- '[ "public" ::: '["abc" ::: 'Table ('[] :=> '["a" ::: 'NoDef :=> 'Null 'PGint4, "b" ::: 'NoDef :=> 'Null 'PGint4, "c" ::: 'NoDef :=> 'Null 'PGint4])]]
130 | -- definition = dropViewIfExists #bc
131 | -- in printSQL definition
132 | -- :}
133 | -- DROP VIEW IF EXISTS "bc";
134 | dropViewIfExists
135 | :: (Has sch db schema, KnownSymbol vw)
136 | => QualifiedAlias sch vw -- ^ view to remove
137 | -> Definition db (Alter sch (DropIfExists vw schema) db)
138 | dropViewIfExists vw = UnsafeDefinition $
139 | "DROP VIEW IF EXISTS" <+> renderSQL vw <> ";"
140 |
141 | -- | `alterViewRename` changes the name of a view from the schema.
142 | --
143 | -- >>> type DB = '[ "public" ::: '[ "foo" ::: 'View '[] ] ]
144 | -- >>> :{
145 | -- let def :: Definition DB '["public" ::: '["bar" ::: 'View '[] ] ]
146 | -- def = alterViewRename #foo #bar
147 | -- in printSQL def
148 | -- :}
149 | -- ALTER VIEW "foo" RENAME TO "bar";
150 | alterViewRename
151 | :: ( Has sch db schema
152 | , KnownSymbol ty1
153 | , Has ty0 schema ('View vw))
154 | => QualifiedAlias sch ty0 -- ^ view to rename
155 | -> Alias ty1 -- ^ what to rename it
156 | -> Definition db (Alter sch (Rename ty0 ty1 schema) db )
157 | alterViewRename vw0 vw1 = UnsafeDefinition $
158 | "ALTER VIEW" <+> renderSQL vw0
159 | <+> "RENAME TO" <+> renderSQL vw1 <> ";"
160 |
161 | {- | This form moves the view into another schema.
162 |
163 | >>> type DB0 = '[ "sch0" ::: '[ "vw" ::: 'View '[] ], "sch1" ::: '[] ]
164 | >>> type DB1 = '[ "sch0" ::: '[], "sch1" ::: '[ "vw" ::: 'View '[] ] ]
165 | >>> :{
166 | let def :: Definition DB0 DB1
167 | def = alterViewSetSchema (#sch0 ! #vw) #sch1
168 | in printSQL def
169 | :}
170 | ALTER VIEW "sch0"."vw" SET SCHEMA "sch1";
171 | -}
172 | alterViewSetSchema
173 | :: ( Has sch0 db schema0
174 | , Has vw schema0 ('View view)
175 | , Has sch1 db schema1 )
176 | => QualifiedAlias sch0 vw -- ^ view to move
177 | -> Alias sch1 -- ^ where to move it
178 | -> Definition db (SetSchema sch0 sch1 schema0 schema1 vw 'View view db)
179 | alterViewSetSchema ty sch = UnsafeDefinition $
180 | "ALTER VIEW" <+> renderSQL ty <+> "SET SCHEMA" <+> renderSQL sch <> ";"
181 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Comparison.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Comparison
3 | Description: comparison functions and operators
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | comparison functions and operators
9 | -}
10 |
11 | {-# LANGUAGE
12 | OverloadedStrings
13 | , RankNTypes
14 | , DataKinds
15 | , PolyKinds
16 | , TypeOperators
17 | #-}
18 |
19 | module Squeal.PostgreSQL.Expression.Comparison
20 | ( -- * Comparison Operators
21 | (.==)
22 | , (./=)
23 | , (.>=)
24 | , (.<)
25 | , (.<=)
26 | , (.>)
27 | -- * Comparison Functions
28 | , greatest
29 | , least
30 | -- * Between
31 | , BetweenExpr
32 | , between
33 | , notBetween
34 | , betweenSymmetric
35 | , notBetweenSymmetric
36 | -- * Null Comparison
37 | , isDistinctFrom
38 | , isNotDistinctFrom
39 | , isTrue
40 | , isNotTrue
41 | , isFalse
42 | , isNotFalse
43 | , isUnknown
44 | , isNotUnknown
45 | ) where
46 |
47 | import Data.ByteString
48 |
49 | import Squeal.PostgreSQL.Expression
50 | import Squeal.PostgreSQL.Expression.Logic
51 | import Squeal.PostgreSQL.Render
52 | import Squeal.PostgreSQL.Type.Schema
53 |
54 | -- $setup
55 | -- >>> import Squeal.PostgreSQL
56 |
57 | -- | Comparison operations like `.==`, `./=`, `.>`, `.>=`, `.<` and `.<=`
58 | -- will produce @NULL@s if one of their arguments is @NULL@.
59 | --
60 | -- >>> printSQL $ true .== null_
61 | -- (TRUE = NULL)
62 | (.==) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
63 | (.==) = unsafeBinaryOp "="
64 | infix 4 .==
65 |
66 | -- | >>> printSQL $ true ./= null_
67 | -- (TRUE <> NULL)
68 | (./=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
69 | (./=) = unsafeBinaryOp "<>"
70 | infix 4 ./=
71 |
72 | -- | >>> printSQL $ true .>= null_
73 | -- (TRUE >= NULL)
74 | (.>=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
75 | (.>=) = unsafeBinaryOp ">="
76 | infix 4 .>=
77 |
78 | -- | >>> printSQL $ true .< null_
79 | -- (TRUE < NULL)
80 | (.<) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
81 | (.<) = unsafeBinaryOp "<"
82 | infix 4 .<
83 |
84 | -- | >>> printSQL $ true .<= null_
85 | -- (TRUE <= NULL)
86 | (.<=) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
87 | (.<=) = unsafeBinaryOp "<="
88 | infix 4 .<=
89 |
90 | -- | >>> printSQL $ true .> null_
91 | -- (TRUE > NULL)
92 | (.>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
93 | (.>) = unsafeBinaryOp ">"
94 | infix 4 .>
95 |
96 | -- | >>> let expr = greatest [param @1] currentTimestamp
97 | -- >>> printSQL expr
98 | -- GREATEST(($1 :: timestamp with time zone), CURRENT_TIMESTAMP)
99 | greatest :: FunctionVar ty ty ty
100 | greatest = unsafeFunctionVar "GREATEST"
101 |
102 | -- | >>> printSQL $ least [null_] currentTimestamp
103 | -- LEAST(NULL, CURRENT_TIMESTAMP)
104 | least :: FunctionVar ty ty ty
105 | least = unsafeFunctionVar "LEAST"
106 |
107 | {- |
108 | A @RankNType@ for comparison expressions like `between`.
109 | -}
110 | type BetweenExpr
111 | = forall grp lat with db params from ty
112 | . Expression grp lat with db params from ty
113 | -> ( Expression grp lat with db params from ty
114 | , Expression grp lat with db params from ty ) -- ^ bounds
115 | -> Condition grp lat with db params from
116 |
117 | unsafeBetweenExpr :: ByteString -> BetweenExpr
118 | unsafeBetweenExpr fun a (x,y) = UnsafeExpression $
119 | renderSQL a <+> fun <+> renderSQL x <+> "AND" <+> renderSQL y
120 |
121 | {- | >>> printSQL $ true `between` (null_, false)
122 | TRUE BETWEEN NULL AND FALSE
123 | -}
124 | between :: BetweenExpr
125 | between = unsafeBetweenExpr "BETWEEN"
126 |
127 | {- | >>> printSQL $ true `notBetween` (null_, false)
128 | TRUE NOT BETWEEN NULL AND FALSE
129 | -}
130 | notBetween :: BetweenExpr
131 | notBetween = unsafeBetweenExpr "NOT BETWEEN"
132 |
133 | {- | between, after sorting the comparison values
134 |
135 | >>> printSQL $ true `betweenSymmetric` (null_, false)
136 | TRUE BETWEEN SYMMETRIC NULL AND FALSE
137 | -}
138 | betweenSymmetric :: BetweenExpr
139 | betweenSymmetric = unsafeBetweenExpr "BETWEEN SYMMETRIC"
140 |
141 | {- | not between, after sorting the comparison values
142 |
143 | >>> printSQL $ true `notBetweenSymmetric` (null_, false)
144 | TRUE NOT BETWEEN SYMMETRIC NULL AND FALSE
145 | -}
146 | notBetweenSymmetric :: BetweenExpr
147 | notBetweenSymmetric = unsafeBetweenExpr "NOT BETWEEN SYMMETRIC"
148 |
149 | {- | not equal, treating null like an ordinary value
150 |
151 | >>> printSQL $ true `isDistinctFrom` null_
152 | (TRUE IS DISTINCT FROM NULL)
153 | -}
154 | isDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool)
155 | isDistinctFrom = unsafeBinaryOp "IS DISTINCT FROM"
156 |
157 | {- | equal, treating null like an ordinary value
158 |
159 | >>> printSQL $ true `isNotDistinctFrom` null_
160 | (TRUE IS NOT DISTINCT FROM NULL)
161 | -}
162 | isNotDistinctFrom :: Operator (null0 ty) (null1 ty) (null 'PGbool)
163 | isNotDistinctFrom = unsafeBinaryOp "IS NOT DISTINCT FROM"
164 |
165 | {- | is true
166 |
167 | >>> printSQL $ true & isTrue
168 | (TRUE IS TRUE)
169 | -}
170 | isTrue :: null0 'PGbool --> null1 'PGbool
171 | isTrue = unsafeRightOp "IS TRUE"
172 |
173 | {- | is false or unknown
174 |
175 | >>> printSQL $ true & isNotTrue
176 | (TRUE IS NOT TRUE)
177 | -}
178 | isNotTrue :: null0 'PGbool --> null1 'PGbool
179 | isNotTrue = unsafeRightOp "IS NOT TRUE"
180 |
181 | {- | is false
182 |
183 | >>> printSQL $ true & isFalse
184 | (TRUE IS FALSE)
185 | -}
186 | isFalse :: null0 'PGbool --> null1 'PGbool
187 | isFalse = unsafeRightOp "IS FALSE"
188 |
189 | {- | is true or unknown
190 |
191 | >>> printSQL $ true & isNotFalse
192 | (TRUE IS NOT FALSE)
193 | -}
194 | isNotFalse :: null0 'PGbool --> null1 'PGbool
195 | isNotFalse = unsafeRightOp "IS NOT FALSE"
196 |
197 | {- | is unknown
198 |
199 | >>> printSQL $ true & isUnknown
200 | (TRUE IS UNKNOWN)
201 | -}
202 | isUnknown :: null0 'PGbool --> null1 'PGbool
203 | isUnknown = unsafeRightOp "IS UNKNOWN"
204 |
205 | {- | is true or false
206 |
207 | >>> printSQL $ true & isNotUnknown
208 | (TRUE IS NOT UNKNOWN)
209 | -}
210 | isNotUnknown :: null0 'PGbool --> null1 'PGbool
211 | isNotUnknown = unsafeRightOp "IS NOT UNKNOWN"
212 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Composite.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Composite
3 | Description: composite functions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | composite functions
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , DataKinds
14 | , FlexibleContexts
15 | , FlexibleInstances
16 | , MultiParamTypeClasses
17 | , OverloadedLabels
18 | , OverloadedStrings
19 | , RankNTypes
20 | , ScopedTypeVariables
21 | , TypeApplications
22 | , TypeFamilies
23 | , TypeOperators
24 | , UndecidableInstances
25 | #-}
26 |
27 | module Squeal.PostgreSQL.Expression.Composite
28 | ( -- * Composite Functions
29 | row
30 | , rowStar
31 | , field
32 | ) where
33 |
34 | import qualified Generics.SOP as SOP
35 |
36 | import Squeal.PostgreSQL.Type.Alias
37 | import Squeal.PostgreSQL.Expression
38 | import Squeal.PostgreSQL.Type.List
39 | import Squeal.PostgreSQL.Render
40 | import Squeal.PostgreSQL.Type.Schema
41 |
42 | -- $setup
43 | -- >>> import Squeal.PostgreSQL
44 |
45 | -- | A row constructor is an expression that builds a row value
46 | -- (also called a composite value) using values for its member fields.
47 | --
48 | -- >>> :{
49 | -- type Complex = 'PGcomposite
50 | -- '[ "real" ::: 'NotNull 'PGfloat8
51 | -- , "imaginary" ::: 'NotNull 'PGfloat8 ]
52 | -- :}
53 | --
54 | -- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression grp lat with db params from ('NotNull Complex)
55 | -- >>> printSQL i
56 | -- ROW((0.0 :: float8), (1.0 :: float8))
57 | row
58 | :: SOP.SListI row
59 | => NP (Aliased (Expression grp lat with db params from)) row
60 | -- ^ zero or more expressions for the row field values
61 | -> Expression grp lat with db params from (null ('PGcomposite row))
62 | row exprs = UnsafeExpression $ "ROW" <> parenthesized
63 | (renderCommaSeparated (\ (expr `As` _) -> renderSQL expr) exprs)
64 |
65 | -- | A row constructor on all columns in a table expression.
66 | rowStar
67 | :: Has tab from row
68 | => Alias tab -- ^ intermediate table
69 | -> Expression grp lat with db params from (null ('PGcomposite row))
70 | rowStar tab = UnsafeExpression $ "ROW" <>
71 | parenthesized (renderSQL tab <> ".*")
72 |
73 | -- | >>> :{
74 | -- type Complex = 'PGcomposite
75 | -- '[ "real" ::: 'NotNull 'PGfloat8
76 | -- , "imaginary" ::: 'NotNull 'PGfloat8 ]
77 | -- type Schema = '["complex" ::: 'Typedef Complex]
78 | -- :}
79 | --
80 | -- >>> let i = row (0 `as` #real :* 1 `as` #imaginary) :: Expression lat '[] grp (Public Schema) from params ('NotNull Complex)
81 | -- >>> printSQL $ i & field #complex #imaginary
82 | -- (ROW((0.0 :: float8), (1.0 :: float8))::"complex")."imaginary"
83 | field
84 | :: ( relss ~ DbRelations db
85 | , Has sch relss rels
86 | , Has rel rels row
87 | , Has field row ty
88 | )
89 | => QualifiedAlias sch rel -- ^ row type
90 | -> Alias field -- ^ field name
91 | -> Expression grp lat with db params from ('NotNull ('PGcomposite row))
92 | -> Expression grp lat with db params from ty
93 | field rel fld expr = UnsafeExpression $
94 | parenthesized (renderSQL expr <> "::" <> renderSQL rel)
95 | <> "." <> renderSQL fld
96 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Default.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Default
3 | Description: optional expressions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | optional expressions
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , GADTs
14 | , LambdaCase
15 | , OverloadedStrings
16 | , PatternSynonyms
17 | , PolyKinds
18 | , QuantifiedConstraints
19 | , RankNTypes
20 | , TypeOperators
21 | #-}
22 |
23 | module Squeal.PostgreSQL.Expression.Default
24 | ( -- * Default
25 | Optional (..)
26 | , mapOptional
27 | , pattern NotDefault
28 | ) where
29 |
30 | import Data.Kind
31 | import Generics.SOP
32 |
33 | import Squeal.PostgreSQL.Render
34 | import Squeal.PostgreSQL.Type.Schema
35 |
36 | -- | `Optional` is either `Default` or `Set`ting of a value,
37 | -- parameterized by an appropriate `Optionality`.
38 | data Optional (expr :: k -> Type) (ty :: (Optionality, k)) where
39 | -- | Use the `Default` value for a column.
40 | Default :: Optional expr ('Def :=> ty)
41 | -- | `Set` a value for a column.
42 | Set :: expr ty -> Optional expr (def :=> ty)
43 |
44 | instance (forall x. RenderSQL (expr x)) => RenderSQL (Optional expr ty) where
45 | renderSQL = \case
46 | Default -> "DEFAULT"
47 | Set x -> renderSQL x
48 |
49 | -- | Map a function over an `Optional` expression.
50 | mapOptional
51 | :: (expr x -> expr y)
52 | -> Optional expr (def :=> x)
53 | -> Optional expr (def :=> y)
54 | mapOptional f = \case
55 | Default -> Default
56 | Set x -> Set (f x)
57 |
58 | -- | `NotDefault` pattern analagous to `Just`.
59 | pattern NotDefault :: ty -> Optional I ('Def :=> ty)
60 | pattern NotDefault x = Set (I x)
61 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Logic.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Logic
3 | Description: logical expressions and operators
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | logical expressions and operators
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , OverloadedStrings
14 | , TypeOperators
15 | #-}
16 |
17 | module Squeal.PostgreSQL.Expression.Logic
18 | ( -- * Condition
19 | Condition
20 | , true
21 | , false
22 | -- * Logic
23 | , not_
24 | , (.&&)
25 | , (.||)
26 | -- * Conditional
27 | , caseWhenThenElse
28 | , ifThenElse
29 | ) where
30 |
31 | import Squeal.PostgreSQL.Expression
32 | import Squeal.PostgreSQL.Render
33 | import Squeal.PostgreSQL.Type.Schema
34 |
35 | -- | A `Condition` is an `Expression`, which can evaluate
36 | -- to `true`, `false` or `Squeal.PostgreSQL.Null.null_`. This is because SQL uses
37 | -- a three valued logic.
38 | type Condition grp lat with db params from =
39 | Expression grp lat with db params from ('Null 'PGbool)
40 |
41 | -- | >>> printSQL true
42 | -- TRUE
43 | true :: Expr (null 'PGbool)
44 | true = UnsafeExpression "TRUE"
45 |
46 | -- | >>> printSQL false
47 | -- FALSE
48 | false :: Expr (null 'PGbool)
49 | false = UnsafeExpression "FALSE"
50 |
51 | -- | >>> printSQL $ not_ true
52 | -- (NOT TRUE)
53 | not_ :: null 'PGbool --> null 'PGbool
54 | not_ = unsafeLeftOp "NOT"
55 |
56 | -- | >>> printSQL $ true .&& false
57 | -- (TRUE AND FALSE)
58 | (.&&) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
59 | infixr 3 .&&
60 | (.&&) = unsafeBinaryOp "AND"
61 |
62 | -- | >>> printSQL $ true .|| false
63 | -- (TRUE OR FALSE)
64 | (.||) :: Operator (null 'PGbool) (null 'PGbool) (null 'PGbool)
65 | infixr 2 .||
66 | (.||) = unsafeBinaryOp "OR"
67 |
68 | -- | >>> :{
69 | -- let
70 | -- expression :: Expression grp lat with db params from (null 'PGint2)
71 | -- expression = caseWhenThenElse [(true, 1), (false, 2)] 3
72 | -- in printSQL expression
73 | -- :}
74 | -- CASE WHEN TRUE THEN (1 :: int2) WHEN FALSE THEN (2 :: int2) ELSE (3 :: int2) END
75 | caseWhenThenElse
76 | :: [ ( Condition grp lat with db params from
77 | , Expression grp lat with db params from ty
78 | ) ]
79 | -- ^ whens and thens
80 | -> Expression grp lat with db params from ty
81 | -- ^ else
82 | -> Expression grp lat with db params from ty
83 | caseWhenThenElse whenThens else_ = UnsafeExpression $ mconcat
84 | [ "CASE"
85 | , mconcat
86 | [ mconcat
87 | [ " WHEN ", renderSQL when_
88 | , " THEN ", renderSQL then_
89 | ]
90 | | (when_,then_) <- whenThens
91 | ]
92 | , " ELSE ", renderSQL else_
93 | , " END"
94 | ]
95 |
96 | -- | >>> :{
97 | -- let
98 | -- expression :: Expression grp lat with db params from (null 'PGint2)
99 | -- expression = ifThenElse true 1 0
100 | -- in printSQL expression
101 | -- :}
102 | -- CASE WHEN TRUE THEN (1 :: int2) ELSE (0 :: int2) END
103 | ifThenElse
104 | :: Condition grp lat with db params from
105 | -> Expression grp lat with db params from ty -- ^ then
106 | -> Expression grp lat with db params from ty -- ^ else
107 | -> Expression grp lat with db params from ty
108 | ifThenElse if_ then_ else_ = caseWhenThenElse [(if_,then_)] else_
109 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Math.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Math
3 | Description: math functions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | math functions
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , OverloadedStrings
14 | , TypeOperators
15 | #-}
16 |
17 | module Squeal.PostgreSQL.Expression.Math
18 | ( -- * Math Function
19 | atan2_
20 | , quot_
21 | , rem_
22 | , trunc
23 | , round_
24 | , ceiling_
25 | ) where
26 |
27 | import Squeal.PostgreSQL.Expression
28 | import Squeal.PostgreSQL.Type.List
29 | import Squeal.PostgreSQL.Type.Schema
30 |
31 | -- $setup
32 | -- >>> import Squeal.PostgreSQL
33 |
34 | -- | >>> :{
35 | -- let
36 | -- expression :: Expr (null 'PGfloat4)
37 | -- expression = atan2_ (pi *: 2)
38 | -- in printSQL expression
39 | -- :}
40 | -- atan2(pi(), (2.0 :: float4))
41 | atan2_ :: float `In` PGFloating => '[ null float, null float] ---> null float
42 | atan2_ = unsafeFunctionN "atan2"
43 |
44 |
45 | -- | integer division, truncates the result
46 | --
47 | -- >>> :{
48 | -- let
49 | -- expression :: Expression grp lat with db params from (null 'PGint2)
50 | -- expression = 5 `quot_` 2
51 | -- in printSQL expression
52 | -- :}
53 | -- ((5 :: int2) / (2 :: int2))
54 | quot_
55 | :: int `In` PGIntegral
56 | => Operator (null int) (null int) (null int)
57 | quot_ = unsafeBinaryOp "/"
58 |
59 | -- | remainder upon integer division
60 | --
61 | -- >>> :{
62 | -- let
63 | -- expression :: Expression grp lat with db params from (null 'PGint2)
64 | -- expression = 5 `rem_` 2
65 | -- in printSQL expression
66 | -- :}
67 | -- ((5 :: int2) % (2 :: int2))
68 | rem_
69 | :: int `In` PGIntegral
70 | => Operator (null int) (null int) (null int)
71 | rem_ = unsafeBinaryOp "%"
72 |
73 | -- | >>> :{
74 | -- let
75 | -- expression :: Expression grp lat with db params from (null 'PGfloat4)
76 | -- expression = trunc pi
77 | -- in printSQL expression
78 | -- :}
79 | -- trunc(pi())
80 | trunc :: frac `In` PGFloating => null frac --> null frac
81 | trunc = unsafeFunction "trunc"
82 |
83 | -- | >>> :{
84 | -- let
85 | -- expression :: Expression grp lat with db params from (null 'PGfloat4)
86 | -- expression = round_ pi
87 | -- in printSQL expression
88 | -- :}
89 | -- round(pi())
90 | round_ :: frac `In` PGFloating => null frac --> null frac
91 | round_ = unsafeFunction "round"
92 |
93 | -- | >>> :{
94 | -- let
95 | -- expression :: Expression grp lat with db params from (null 'PGfloat4)
96 | -- expression = ceiling_ pi
97 | -- in printSQL expression
98 | -- :}
99 | -- ceiling(pi())
100 | ceiling_ :: frac `In` PGFloating => null frac --> null frac
101 | ceiling_ = unsafeFunction "ceiling"
102 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Null.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Null
3 | Description: null expressions and handlers
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | null expressions and handlers
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , KindSignatures
14 | , OverloadedStrings
15 | , RankNTypes
16 | , TypeFamilies
17 | , TypeOperators
18 | #-}
19 |
20 | module Squeal.PostgreSQL.Expression.Null
21 | ( -- * Null
22 | null_
23 | , just_
24 | , unsafeNotNull
25 | , monoNotNull
26 | , coalesce
27 | , fromNull
28 | , isNull
29 | , isNotNull
30 | , matchNull
31 | , nullIf
32 | , CombineNullity
33 | -- deprecated
34 | , notNull
35 | ) where
36 |
37 | import Squeal.PostgreSQL.Expression
38 | import Squeal.PostgreSQL.Expression.Logic
39 | import Squeal.PostgreSQL.Render
40 | import Squeal.PostgreSQL.Type.Schema
41 |
42 | -- $setup
43 | -- >>> import Squeal.PostgreSQL
44 |
45 | -- | analagous to `Nothing`
46 | --
47 | -- >>> printSQL null_
48 | -- NULL
49 | null_ :: Expr ('Null ty)
50 | null_ = UnsafeExpression "NULL"
51 |
52 | -- | analagous to `Just`
53 | --
54 | -- >>> printSQL $ just_ true
55 | -- TRUE
56 | just_ :: 'NotNull ty --> 'Null ty
57 | just_ = UnsafeExpression . renderSQL
58 |
59 | -- | analagous to `Just`
60 | {-# DEPRECATED notNull "use just_ instead" #-}
61 | notNull :: 'NotNull ty --> 'Null ty
62 | notNull = UnsafeExpression . renderSQL
63 |
64 | -- | Analagous to `Data.Maybe.fromJust` inverse to `notNull`,
65 | -- useful when you know an `Expression` is `NotNull`,
66 | -- because, for instance, you've filtered out @NULL@
67 | -- values in a column.
68 | unsafeNotNull :: 'Null ty --> 'NotNull ty
69 | unsafeNotNull = UnsafeExpression . renderSQL
70 |
71 | -- | Some expressions are null polymorphic which may raise
72 | -- inference issues. Use `monoNotNull` to fix their
73 | -- nullity as `NotNull`.
74 | monoNotNull
75 | :: (forall null. Expression grp lat with db params from (null ty))
76 | -- ^ null polymorphic
77 | -> Expression grp lat with db params from ('NotNull ty)
78 | monoNotNull x = x
79 |
80 | -- | return the leftmost value which is not NULL
81 | --
82 | -- >>> printSQL $ coalesce [null_, true] false
83 | -- COALESCE(NULL, TRUE, FALSE)
84 | coalesce :: FunctionVar ('Null ty) (null ty) (null ty)
85 | coalesce nullxs notNullx = UnsafeExpression $
86 | "COALESCE" <> parenthesized (commaSeparated
87 | ((renderSQL <$> nullxs) <> [renderSQL notNullx]))
88 |
89 | -- | analagous to `Data.Maybe.fromMaybe` using @COALESCE@
90 | --
91 | -- >>> printSQL $ fromNull true null_
92 | -- COALESCE(NULL, TRUE)
93 | fromNull
94 | :: Expression grp lat with db params from ('NotNull ty)
95 | -- ^ what to convert @NULL@ to
96 | -> Expression grp lat with db params from ('Null ty)
97 | -> Expression grp lat with db params from ('NotNull ty)
98 | fromNull notNullx nullx = coalesce [nullx] notNullx
99 |
100 | -- | >>> printSQL $ null_ & isNull
101 | -- NULL IS NULL
102 | isNull :: 'Null ty --> null 'PGbool
103 | isNull x = UnsafeExpression $ renderSQL x <+> "IS NULL"
104 |
105 | -- | >>> printSQL $ null_ & isNotNull
106 | -- NULL IS NOT NULL
107 | isNotNull :: 'Null ty --> null 'PGbool
108 | isNotNull x = UnsafeExpression $ renderSQL x <+> "IS NOT NULL"
109 |
110 | -- | analagous to `maybe` using @IS NULL@
111 | --
112 | -- >>> printSQL $ matchNull true not_ null_
113 | -- CASE WHEN NULL IS NULL THEN TRUE ELSE (NOT NULL) END
114 | matchNull
115 | :: Expression grp lat with db params from (nullty)
116 | -- ^ what to convert @NULL@ to
117 | -> ( Expression grp lat with db params from ('NotNull ty)
118 | -> Expression grp lat with db params from (nullty) )
119 | -- ^ function to perform when @NULL@ is absent
120 | -> Expression grp lat with db params from ('Null ty)
121 | -> Expression grp lat with db params from (nullty)
122 | matchNull y f x = ifThenElse (isNull x) y
123 | (f (UnsafeExpression (renderSQL x)))
124 |
125 | {-| right inverse to `fromNull`, if its arguments are equal then
126 | `nullIf` gives @NULL@.
127 |
128 | >>> :set -XTypeApplications
129 | >>> printSQL (nullIf (false *: param @1))
130 | NULLIF(FALSE, ($1 :: bool))
131 | -}
132 | nullIf :: '[ 'NotNull ty, 'NotNull ty] ---> 'Null ty
133 | nullIf = unsafeFunctionN "NULLIF"
134 |
135 | {-| Make the return type of the type family `NotNull` if both arguments are,
136 | or `Null` otherwise.
137 | -}
138 | type family CombineNullity
139 | (lhs :: PGType -> NullType) (rhs :: PGType -> NullType) :: PGType -> NullType where
140 | CombineNullity 'NotNull 'NotNull = 'NotNull
141 | CombineNullity _ _ = 'Null
142 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Parameter.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Parameter
3 | Description: out-of-line parameters
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | out-of-line parameters
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , DataKinds
14 | , FlexibleContexts
15 | , FlexibleInstances
16 | , FunctionalDependencies
17 | , GADTs
18 | , KindSignatures
19 | , MultiParamTypeClasses
20 | , OverloadedStrings
21 | , RankNTypes
22 | , ScopedTypeVariables
23 | , TypeApplications
24 | , TypeFamilies
25 | , TypeOperators
26 | , UndecidableInstances
27 | #-}
28 |
29 | module Squeal.PostgreSQL.Expression.Parameter
30 | ( -- * Parameter
31 | HasParameter (parameter)
32 | , param
33 | -- * Parameter Internals
34 | , HasParameter'
35 | , ParamOutOfBoundsError
36 | , ParamTypeMismatchError
37 | ) where
38 |
39 | import Data.Kind (Constraint)
40 | import GHC.Exts (Any)
41 | import GHC.TypeLits
42 |
43 | import Squeal.PostgreSQL.Expression
44 | import Squeal.PostgreSQL.Expression.Type
45 | import Squeal.PostgreSQL.Render
46 | import Squeal.PostgreSQL.Type.Schema
47 |
48 | -- $setup
49 | -- >>> import Squeal.PostgreSQL
50 |
51 | {- | A `HasParameter` constraint is used to indicate a value that is
52 | supplied externally to a SQL statement.
53 | `Squeal.PostgreSQL.Session.manipulateParams`,
54 | `Squeal.PostgreSQL.Session.queryParams` and
55 | `Squeal.PostgreSQL.Session.traversePrepared` support specifying data values
56 | separately from the SQL command string, in which case `param`s are used to
57 | refer to the out-of-line data values.
58 | -}
59 | class KnownNat ix => HasParameter
60 | (ix :: Nat)
61 | (params :: [NullType])
62 | (ty :: NullType)
63 | | ix params -> ty where
64 | -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
65 | --
66 | -- >>> printSQL (parameter @1 int4)
67 | -- ($1 :: int4)
68 | parameter
69 | :: TypeExpression db ty
70 | -> Expression grp lat with db params from ty
71 | parameter ty = UnsafeExpression $ parenthesized $
72 | "$" <> renderNat @ix <+> "::"
73 | <+> renderSQL ty
74 |
75 | -- we could do the check for 0 in @HasParameter'@, but this way forces checking 'ix' before delegating,
76 | -- which has the nice effect of ambiguous 'ix' errors mentioning 'HasParameter' instead of @HasParameter'@
77 | instance {-# OVERLAPS #-} (TypeError ('Text "Tried to get the param at index 0, but params are 1-indexed"), x ~ Any) => HasParameter 0 params x
78 | instance {-# OVERLAPS #-} (KnownNat ix, HasParameter' ix params ix params x) => HasParameter ix params x
79 |
80 | -- | @HasParameter'@ is an implementation detail of 'HasParameter' allowing us to
81 | -- include the full parameter list in our errors.
82 | class KnownNat ix => HasParameter'
83 | (originalIx :: Nat)
84 | (allParams :: [NullType])
85 | (ix :: Nat)
86 | (params :: [NullType])
87 | (ty :: NullType)
88 | | ix params -> ty where
89 | instance {-# OVERLAPS #-}
90 | ( params ~ (y ': xs)
91 | , y ~ x -- having a separate 'y' type variable is required for 'ParamTypeMismatchError'
92 | , ParamOutOfBoundsError originalIx allParams params
93 | , ParamTypeMismatchError originalIx allParams x y
94 | ) => HasParameter' originalIx allParams 1 params x
95 | instance {-# OVERLAPS #-}
96 | ( KnownNat ix
97 | , HasParameter' originalIx allParams (ix-1) xs x
98 | , params ~ (y ': xs)
99 | , ParamOutOfBoundsError originalIx allParams params
100 | )
101 | => HasParameter' originalIx allParams ix params x
102 |
103 | -- | @ParamOutOfBoundsError@ reports a nicer error with more context when we try to do an out-of-bounds lookup successfully do a lookup but
104 | -- find a different field than we expected, or when we find ourself out of bounds
105 | type family ParamOutOfBoundsError (originalIx :: Nat) (allParams :: [NullType]) (params :: [NullType]) :: Constraint where
106 | ParamOutOfBoundsError originalIx allParams '[] = TypeError
107 | ('Text "Index " ':<>: 'ShowType originalIx ':<>: 'Text " is out of bounds in 1-indexed parameter list:" ':$$: 'ShowType allParams)
108 | ParamOutOfBoundsError _ _ _ = ()
109 |
110 | -- | @ParamTypeMismatchError@ reports a nicer error with more context when we successfully do a lookup but
111 | -- find a different field than we expected, or when we find ourself out of bounds
112 | type family ParamTypeMismatchError (originalIx :: Nat) (allParams :: [NullType]) (found :: NullType) (expected :: NullType) :: Constraint where
113 | ParamTypeMismatchError _ _ found found = ()
114 | ParamTypeMismatchError originalIx allParams found expected = TypeError
115 | ( 'Text "Type mismatch when looking up param at index " ':<>: 'ShowType originalIx
116 | ':$$: 'Text "in 1-indexed parameter list:"
117 | ':$$: 'Text " " ':<>: 'ShowType allParams
118 | ':$$: 'Text ""
119 | ':$$: 'Text "Expected: " ':<>: 'ShowType expected
120 | ':$$: 'Text "But found: " ':<>: 'ShowType found
121 | ':$$: 'Text ""
122 | )
123 |
124 | -- | `param` takes a `Nat` using type application and for basic types,
125 | -- infers a `TypeExpression`.
126 | --
127 | -- >>> printSQL (param @1 @('Null 'PGint4))
128 | -- ($1 :: int4)
129 | param
130 | :: forall n ty lat with db params from grp
131 | . (NullTyped db ty, HasParameter n params ty)
132 | => Expression grp lat with db params from ty -- ^ param
133 | param = parameter @n (nulltype @db)
134 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Range.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Range
3 | Description: range types and functions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | range types and functions
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , DataKinds
14 | , DeriveAnyClass
15 | , DeriveGeneric
16 | , DeriveFoldable
17 | , DerivingStrategies
18 | , DeriveTraversable
19 | , FlexibleContexts
20 | , FlexibleInstances
21 | , LambdaCase
22 | , MultiParamTypeClasses
23 | , OverloadedLabels
24 | , OverloadedStrings
25 | , PatternSynonyms
26 | , RankNTypes
27 | , ScopedTypeVariables
28 | , TypeApplications
29 | , TypeFamilies
30 | , TypeOperators
31 | , UndecidableInstances
32 | #-}
33 |
34 | module Squeal.PostgreSQL.Expression.Range
35 | ( -- * Range
36 | Range (..)
37 | , (<=..<=), (<..<), (<=..<), (<..<=)
38 | , moreThan, atLeast, lessThan, atMost
39 | , singleton, whole
40 | , Bound (..)
41 | -- * Range Function
42 | -- ** Range Construction
43 | , range
44 | -- ** Range Operator
45 | , (.<@)
46 | , (@>.)
47 | , (<<@)
48 | , (@>>)
49 | , (&<)
50 | , (&>)
51 | , (-|-)
52 | , (@+)
53 | , (@*)
54 | , (@-)
55 | -- ** Range Function
56 | , lowerBound
57 | , upperBound
58 | , isEmpty
59 | , lowerInc
60 | , lowerInf
61 | , upperInc
62 | , upperInf
63 | , rangeMerge
64 | ) where
65 |
66 | import qualified GHC.Generics as GHC
67 | import qualified Generics.SOP as SOP
68 |
69 | import Squeal.PostgreSQL.Expression
70 | import Squeal.PostgreSQL.Expression.Type hiding (bool)
71 | import Squeal.PostgreSQL.Type.PG
72 | import Squeal.PostgreSQL.Render
73 | import Squeal.PostgreSQL.Type.Schema
74 |
75 | -- $setup
76 | -- >>> import Squeal.PostgreSQL (tstzrange, numrange, int4range, now, printSQL)
77 |
78 | -- | Construct a `range`
79 | --
80 | -- >>> printSQL $ range tstzrange (atLeast now)
81 | -- tstzrange(now(), NULL, '[)')
82 | -- >>> printSQL $ range numrange (0 <=..< 2*pi)
83 | -- numrange((0.0 :: numeric), ((2.0 :: numeric) * pi()), '[)')
84 | -- >>> printSQL $ range int4range Empty
85 | -- ('empty' :: int4range)
86 | range
87 | :: TypeExpression db (null ('PGrange ty))
88 | -- ^ range type
89 | -> Range (Expression grp lat with db params from ('NotNull ty))
90 | -- ^ range of values
91 | -> Expression grp lat with db params from (null ('PGrange ty))
92 | range ty = \case
93 | Empty -> UnsafeExpression $ parenthesized
94 | (emp <+> "::" <+> renderSQL ty)
95 | NonEmpty l u -> UnsafeExpression $ renderSQL ty <> parenthesized
96 | (commaSeparated (args l u))
97 | where
98 | emp = singleQuote <> "empty" <> singleQuote
99 | args l u = [arg l, arg u, singleQuote <> bra l <> ket u <> singleQuote]
100 | singleQuote = "\'"
101 | arg = \case
102 | Infinite -> "NULL"; Closed x -> renderSQL x; Open x -> renderSQL x
103 | bra = \case Infinite -> "("; Closed _ -> "["; Open _ -> "("
104 | ket = \case Infinite -> ")"; Closed _ -> "]"; Open _ -> ")"
105 |
106 | -- | The type of `Bound` for a `Range`.
107 | data Bound x
108 | = Infinite -- ^ unbounded
109 | | Closed x -- ^ inclusive
110 | | Open x -- ^ exclusive
111 | deriving
112 | ( Eq, Ord, Show, Read, GHC.Generic
113 | , Functor, Foldable, Traversable )
114 |
115 | -- | A `Range` datatype that comprises connected subsets of
116 | -- the real line.
117 | data Range x = Empty | NonEmpty (Bound x) (Bound x)
118 | deriving
119 | ( Eq, Ord, Show, Read, GHC.Generic
120 | , Functor, Foldable, Traversable )
121 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
122 | -- | `PGrange` @(@`PG` @hask)@
123 | instance IsPG hask => IsPG (Range hask) where
124 | type PG (Range hask) = 'PGrange (PG hask)
125 |
126 | -- | Finite `Range` constructor
127 | (<=..<=), (<..<), (<=..<), (<..<=) :: x -> x -> Range x
128 | infix 4 <=..<=, <..<, <=..<, <..<=
129 | x <=..<= y = NonEmpty (Closed x) (Closed y)
130 | x <..< y = NonEmpty (Open x) (Open y)
131 | x <=..< y = NonEmpty (Closed x) (Open y)
132 | x <..<= y = NonEmpty (Open x) (Closed y)
133 |
134 | -- | Half-infinite `Range` constructor
135 | moreThan, atLeast, lessThan, atMost :: x -> Range x
136 | moreThan x = NonEmpty (Open x) Infinite
137 | atLeast x = NonEmpty (Closed x) Infinite
138 | lessThan x = NonEmpty Infinite (Open x)
139 | atMost x = NonEmpty Infinite (Closed x)
140 |
141 | -- | A point on the line
142 | singleton :: x -> Range x
143 | singleton x = x <=..<= x
144 |
145 | -- | The `whole` line
146 | whole :: Range x
147 | whole = NonEmpty Infinite Infinite
148 |
149 | -- | range is contained by
150 | (.<@) :: Operator (null0 ty) (null1 ('PGrange ty)) ('Null 'PGbool)
151 | (.<@) = unsafeBinaryOp "<@"
152 |
153 | -- | contains range
154 | (@>.) :: Operator (null0 ('PGrange ty)) (null1 ty) ('Null 'PGbool)
155 | (@>.) = unsafeBinaryOp "@>"
156 |
157 | -- | strictly left of,
158 | -- return false when an empty range is involved
159 | (<<@) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
160 | (<<@) = unsafeBinaryOp "<<"
161 |
162 | -- | strictly right of,
163 | -- return false when an empty range is involved
164 | (@>>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
165 | (@>>) = unsafeBinaryOp ">>"
166 |
167 | -- | does not extend to the right of,
168 | -- return false when an empty range is involved
169 | (&<) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
170 | (&<) = unsafeBinaryOp "&<"
171 |
172 | -- | does not extend to the left of,
173 | -- return false when an empty range is involved
174 | (&>) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
175 | (&>) = unsafeBinaryOp "&>"
176 |
177 | -- | is adjacent to, return false when an empty range is involved
178 | (-|-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) ('Null 'PGbool)
179 | (-|-) = unsafeBinaryOp "-|-"
180 |
181 | -- | union, will fail if the resulting range would
182 | -- need to contain two disjoint sub-ranges
183 | (@+) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
184 | (@+) = unsafeBinaryOp "+"
185 |
186 | -- | intersection
187 | (@*) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
188 | (@*) = unsafeBinaryOp "*"
189 |
190 | -- | difference, will fail if the resulting range would
191 | -- need to contain two disjoint sub-ranges
192 | (@-) :: Operator (null ('PGrange ty)) (null ('PGrange ty)) (null ('PGrange ty))
193 | (@-) = unsafeBinaryOp "-"
194 |
195 | -- | lower bound of range
196 | lowerBound :: null ('PGrange ty) --> 'Null ty
197 | lowerBound = unsafeFunction "lower"
198 |
199 | -- | upper bound of range
200 | upperBound :: null ('PGrange ty) --> 'Null ty
201 | upperBound = unsafeFunction "upper"
202 |
203 | -- | is the range empty?
204 | isEmpty :: null ('PGrange ty) --> 'Null 'PGbool
205 | isEmpty = unsafeFunction "isempty"
206 |
207 | -- | is the lower bound inclusive?
208 | lowerInc :: null ('PGrange ty) --> 'Null 'PGbool
209 | lowerInc = unsafeFunction "lower_inc"
210 |
211 | -- | is the lower bound infinite?
212 | lowerInf :: null ('PGrange ty) --> 'Null 'PGbool
213 | lowerInf = unsafeFunction "lower_inf"
214 |
215 | -- | is the upper bound inclusive?
216 | upperInc :: null ('PGrange ty) --> 'Null 'PGbool
217 | upperInc = unsafeFunction "upper_inc"
218 |
219 | -- | is the upper bound infinite?
220 | upperInf :: null ('PGrange ty) --> 'Null 'PGbool
221 | upperInf = unsafeFunction "upper_inf"
222 |
223 | -- | the smallest range which includes both of the given ranges
224 | rangeMerge ::
225 | '[null ('PGrange ty), null ('PGrange ty)]
226 | ---> null ('PGrange ty)
227 | rangeMerge = unsafeFunctionN "range_merge"
228 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Sort.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Sort
3 | Description: sort expressions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | sort expressions
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , FlexibleInstances
14 | , FunctionalDependencies
15 | , GADTs
16 | , LambdaCase
17 | , MultiParamTypeClasses
18 | , OverloadedStrings
19 | , StandaloneDeriving
20 | #-}
21 |
22 | module Squeal.PostgreSQL.Expression.Sort
23 | ( -- * Sort
24 | SortExpression (..)
25 | , OrderBy (..)
26 | ) where
27 |
28 | import Squeal.PostgreSQL.Expression
29 | import Squeal.PostgreSQL.Render
30 | import Squeal.PostgreSQL.Type.Schema
31 |
32 | -- | `SortExpression`s are used by `orderBy` to optionally sort the results
33 | -- of a `Squeal.PostgreSQL.Query.Query`. `Asc` or `Desc`
34 | -- set the sort direction of a `NotNull` result
35 | -- column to ascending or descending. Ascending order puts smaller values
36 | -- first, where "smaller" is defined in terms of the
37 | -- `Squeal.PostgreSQL.Expression.Comparison..<` operator. Similarly,
38 | -- descending order is determined with the
39 | -- `Squeal.PostgreSQL.Expression.Comparison..>` operator. `AscNullsFirst`,
40 | -- `AscNullsLast`, `DescNullsFirst` and `DescNullsLast` options are used to
41 | -- determine whether nulls appear before or after non-null values in the sort
42 | -- ordering of a `Null` result column.
43 | data SortExpression grp lat with db params from where
44 | Asc
45 | :: Expression grp lat with db params from ('NotNull ty)
46 | -- ^ sort by
47 | -> SortExpression grp lat with db params from
48 | Desc
49 | :: Expression grp lat with db params from ('NotNull ty)
50 | -- ^ sort by
51 | -> SortExpression grp lat with db params from
52 | AscNullsFirst
53 | :: Expression grp lat with db params from ('Null ty)
54 | -- ^ sort by
55 | -> SortExpression grp lat with db params from
56 | AscNullsLast
57 | :: Expression grp lat with db params from ('Null ty)
58 | -- ^ sort by
59 | -> SortExpression grp lat with db params from
60 | DescNullsFirst
61 | :: Expression grp lat with db params from ('Null ty)
62 | -- ^ sort by
63 | -> SortExpression grp lat with db params from
64 | DescNullsLast
65 | :: Expression grp lat with db params from ('Null ty)
66 | -- ^ sort by
67 | -> SortExpression grp lat with db params from
68 | deriving instance Show (SortExpression grp lat with db params from)
69 | instance RenderSQL (SortExpression grp lat with db params from) where
70 | renderSQL = \case
71 | Asc expression -> renderSQL expression <+> "ASC"
72 | Desc expression -> renderSQL expression <+> "DESC"
73 | AscNullsFirst expression -> renderSQL expression
74 | <+> "ASC NULLS FIRST"
75 | DescNullsFirst expression -> renderSQL expression
76 | <+> "DESC NULLS FIRST"
77 | AscNullsLast expression -> renderSQL expression <+> "ASC NULLS LAST"
78 | DescNullsLast expression -> renderSQL expression <+> "DESC NULLS LAST"
79 | instance RenderSQL [SortExpression grp lat with db params from] where
80 | renderSQL = \case
81 | [] -> ""
82 | srts -> " ORDER BY"
83 | <+> commaSeparated (renderSQL <$> srts)
84 |
85 | {- |
86 | The `orderBy` clause causes the result rows of a `Squeal.PostgreSQL.Query.TableExpression`
87 | to be sorted according to the specified `SortExpression`(s).
88 | If two rows are equal according to the leftmost expression,
89 | they are compared according to the next expression and so on.
90 | If they are equal according to all specified expressions,
91 | they are returned in an implementation-dependent order.
92 |
93 | You can also control the order in which rows are processed by window functions
94 | using `orderBy` within `Squeal.PostgreSQL.Query.Over`.
95 | -}
96 | class OrderBy expr grp | expr -> grp where
97 | orderBy
98 | :: [SortExpression grp lat with db params from]
99 | -- ^ sorts
100 | -> expr lat with db params from
101 | -> expr lat with db params from
102 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Subquery.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Subquery
3 | Description: subquery expressions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | subquery expressions
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , OverloadedStrings
14 | , RankNTypes
15 | , TypeOperators
16 | #-}
17 |
18 | module Squeal.PostgreSQL.Expression.Subquery
19 | ( -- * Subquery
20 | exists
21 | , in_
22 | , notIn
23 | , subAll
24 | , subAny
25 | ) where
26 |
27 | import Squeal.PostgreSQL.Type.Alias
28 | import Squeal.PostgreSQL.Expression
29 | import Squeal.PostgreSQL.Expression.Logic
30 | import Squeal.PostgreSQL.Type.List
31 | import Squeal.PostgreSQL.Query
32 | import Squeal.PostgreSQL.Render
33 | import Squeal.PostgreSQL.Type.Schema
34 |
35 | -- $setup
36 | -- >>> import Squeal.PostgreSQL
37 |
38 | {- |
39 | The argument of `exists` is an arbitrary subquery. The subquery is evaluated
40 | to determine whether it returns any rows. If it returns at least one row,
41 | the result of `exists` is `true`; if the subquery returns no rows,
42 | the result of `exists` is `false`.
43 |
44 | The subquery can refer to variables from the surrounding query,
45 | which will act as constants during any one evaluation of the subquery.
46 |
47 | The subquery will generally only be executed long enough to determine whether
48 | at least one row is returned, not all the way to completion.
49 | -}
50 | exists
51 | :: Query (Join lat from) with db params row
52 | -- ^ subquery
53 | -> Expression grp lat with db params from (null 'PGbool)
54 | exists query = UnsafeExpression $ "EXISTS" <+> parenthesized (renderSQL query)
55 |
56 | {- |
57 | The right-hand side is a parenthesized subquery, which must return
58 | exactly one column. The left-hand expression is evaluated and compared to each
59 | row of the subquery result using the given `Operator`,
60 | which must yield a Boolean result. The result of `subAll` is `true`
61 | if all rows yield true (including the case where the subquery returns no rows).
62 | The result is `false` if any `false` result is found.
63 | The result is `Squeal.PostgreSQL.Expression.Null.null_` if
64 | no comparison with a subquery row returns `false`,
65 | and at least one comparison returns `Squeal.PostgreSQL.Expression.Null.null_`.
66 |
67 | >>> printSQL $ subAll true (.==) (values_ (true `as` #foo))
68 | (TRUE = ALL (SELECT * FROM (VALUES (TRUE)) AS t ("foo")))
69 | -}
70 | subAll
71 | :: Expression grp lat with db params from ty1 -- ^ expression
72 | -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
73 | -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery
74 | -> Condition grp lat with db params from
75 | subAll expr (?) qry = expr ?
76 | (UnsafeExpression $ "ALL" <+> parenthesized (renderSQL qry))
77 |
78 | {- |
79 | The right-hand side is a parenthesized subquery, which must return exactly one column.
80 | The left-hand expression is evaluated and compared to each row of the subquery result
81 | using the given `Operator`, which must yield a Boolean result. The result of `subAny` is `true`
82 | if any `true` result is obtained. The result is `false` if no true result is found
83 | (including the case where the subquery returns no rows).
84 |
85 | >>> printSQL $ subAny "foo" like (values_ ("foobar" `as` #foo))
86 | ((E'foo' :: text) LIKE ANY (SELECT * FROM (VALUES ((E'foobar' :: text))) AS t ("foo")))
87 | -}
88 | subAny
89 | :: Expression grp lat with db params from ty1 -- ^ expression
90 | -> Operator ty1 ty2 ('Null 'PGbool) -- ^ operator
91 | -> Query (Join lat from) with db params '[col ::: ty2] -- ^ subquery
92 | -> Condition grp lat with db params from
93 | subAny expr (?) qry = expr ?
94 | (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL qry))
95 |
96 | {- |
97 | The result is `true` if the left-hand expression's result is equal
98 | to any of the right-hand expressions.
99 |
100 | >>> printSQL $ true `in_` [true, false, null_]
101 | TRUE IN (TRUE, FALSE, NULL)
102 | -}
103 | in_
104 | :: Expression grp lat with db params from ty -- ^ expression
105 | -> [Expression grp lat with db params from ty]
106 | -> Expression grp lat with db params from ('Null 'PGbool)
107 | _ `in_` [] = false
108 | expr `in_` exprs = UnsafeExpression $ renderSQL expr <+> "IN"
109 | <+> parenthesized (commaSeparated (renderSQL <$> exprs))
110 |
111 | {- |
112 | The result is `true` if the left-hand expression's result is not equal
113 | to any of the right-hand expressions.
114 |
115 | >>> printSQL $ true `notIn` [false, null_]
116 | TRUE NOT IN (FALSE, NULL)
117 | -}
118 | notIn
119 | :: Expression grp lat with db params from ty -- ^ expression
120 | -> [Expression grp lat with db params from ty]
121 | -> Expression grp lat with db params from ('Null 'PGbool)
122 | _ `notIn` [] = true
123 | expr `notIn` exprs = UnsafeExpression $ renderSQL expr <+> "NOT IN"
124 | <+> parenthesized (commaSeparated (renderSQL <$> exprs))
125 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Text.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Text
3 | Description: text functions and operators
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | text functions and operators
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , OverloadedStrings
14 | , RankNTypes
15 | , ScopedTypeVariables
16 | , TypeOperators
17 | #-}
18 |
19 | module Squeal.PostgreSQL.Expression.Text
20 | ( -- * Text Function
21 | lower
22 | , upper
23 | , charLength
24 | , like
25 | , ilike
26 | , replace
27 | , strpos
28 | ) where
29 |
30 | import Squeal.PostgreSQL.Expression
31 | import Squeal.PostgreSQL.Type.Schema
32 |
33 | -- $setup
34 | -- >>> import Squeal.PostgreSQL
35 |
36 | -- | >>> printSQL $ lower "ARRRGGG"
37 | -- lower((E'ARRRGGG' :: text))
38 | lower :: null 'PGtext --> null 'PGtext
39 | lower = unsafeFunction "lower"
40 |
41 | -- | >>> printSQL $ upper "eeee"
42 | -- upper((E'eeee' :: text))
43 | upper :: null 'PGtext --> null 'PGtext
44 | upper = unsafeFunction "upper"
45 |
46 | -- | >>> printSQL $ charLength "four"
47 | -- char_length((E'four' :: text))
48 | charLength :: null 'PGtext --> null 'PGint4
49 | charLength = unsafeFunction "char_length"
50 |
51 | -- | The `like` expression returns true if the @string@ matches
52 | -- the supplied @pattern@. If @pattern@ does not contain percent signs
53 | -- or underscores, then the pattern only represents the string itself;
54 | -- in that case `like` acts like the equals operator. An underscore (_)
55 | -- in pattern stands for (matches) any single character; a percent sign (%)
56 | -- matches any sequence of zero or more characters.
57 | --
58 | -- >>> printSQL $ "abc" `like` "a%"
59 | -- ((E'abc' :: text) LIKE (E'a%' :: text))
60 | like :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
61 | like = unsafeBinaryOp "LIKE"
62 |
63 | -- | The key word ILIKE can be used instead of LIKE to make the
64 | -- match case-insensitive according to the active locale.
65 | --
66 | -- >>> printSQL $ "abc" `ilike` "a%"
67 | -- ((E'abc' :: text) ILIKE (E'a%' :: text))
68 | ilike :: Operator (null 'PGtext) (null 'PGtext) ('Null 'PGbool)
69 | ilike = unsafeBinaryOp "ILIKE"
70 |
71 | -- | Determines the location of the substring match using the `strpos`
72 | -- function. Returns the 1-based index of the first match, if no
73 | -- match exists the function returns (0).
74 | --
75 | -- >>> printSQL $ strpos ("string" *: "substring")
76 | -- strpos((E'string' :: text), (E'substring' :: text))
77 | strpos
78 | :: '[null 'PGtext, null 'PGtext] ---> null 'PGint4
79 | strpos = unsafeFunctionN "strpos"
80 |
81 | -- | Over the string in the first argument, replace all occurrences of
82 | -- the second argument with the third and return the modified string.
83 | --
84 | -- >>> printSQL $ replace ("string" :* "from" *: "to")
85 | -- replace((E'string' :: text), (E'from' :: text), (E'to' :: text))
86 | replace
87 | :: '[ null 'PGtext, null 'PGtext, null 'PGtext ] ---> null 'PGtext
88 | replace = unsafeFunctionN "replace"
89 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/TextSearch.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.TextSearch
3 | Description: text search functions and operators
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | text search functions and operators
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , OverloadedStrings
14 | , TypeOperators
15 | #-}
16 |
17 | module Squeal.PostgreSQL.Expression.TextSearch
18 | ( -- * Text Search Operator
19 | (@@)
20 | , (.&)
21 | , (.|)
22 | , (.!)
23 | , (<->)
24 | -- * Text Search Function
25 | , arrayToTSvector
26 | , tsvectorLength
27 | , numnode
28 | , plainToTSquery
29 | , phraseToTSquery
30 | , websearchToTSquery
31 | , queryTree
32 | , toTSquery
33 | , toTSvector
34 | , setWeight
35 | , strip
36 | , jsonToTSvector
37 | , jsonbToTSvector
38 | , tsDelete
39 | , tsFilter
40 | , tsHeadline
41 | ) where
42 |
43 | import Squeal.PostgreSQL.Expression
44 | import Squeal.PostgreSQL.Type.List
45 | import Squeal.PostgreSQL.Type.Schema
46 |
47 | -- | `Squeal.PostgreSQL.Expression.Type.tsvector` matches tsquery ?
48 | (@@) :: Operator (null 'PGtsvector) (null 'PGtsquery) ('Null 'PGbool)
49 | (@@) = unsafeBinaryOp "@@"
50 |
51 | -- | AND `Squeal.PostgreSQL.Expression.Type.tsquery`s together
52 | (.&) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
53 | (.&) = unsafeBinaryOp "&&"
54 |
55 | -- | OR `Squeal.PostgreSQL.Expression.Type.tsquery`s together
56 | (.|) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
57 | (.|) = unsafeBinaryOp "||"
58 |
59 | -- | negate a `Squeal.PostgreSQL.Expression.Type.tsquery`
60 | (.!) :: null 'PGtsquery --> null 'PGtsquery
61 | (.!) = unsafeLeftOp "!!"
62 |
63 | -- | `Squeal.PostgreSQL.Expression.Type.tsquery` followed by
64 | -- `Squeal.PostgreSQL.Expression.Type.tsquery`
65 | (<->) :: Operator (null 'PGtsquery) (null 'PGtsquery) (null 'PGtsquery)
66 | (<->) = unsafeBinaryOp "<->"
67 |
68 | -- | convert array of lexemes to `Squeal.PostgreSQL.Expression.Type.tsvector`
69 | arrayToTSvector
70 | :: null ('PGvararray ('NotNull 'PGtext))
71 | --> null 'PGtsvector
72 | arrayToTSvector = unsafeFunction "array_to_tsvector"
73 |
74 | -- | number of lexemes in `Squeal.PostgreSQL.Expression.Type.tsvector`
75 | tsvectorLength :: null 'PGtsvector --> null 'PGint4
76 | tsvectorLength = unsafeFunction "length"
77 |
78 | -- | number of lexemes plus operators in `Squeal.PostgreSQL.Expression.Type.tsquery`
79 | numnode :: null 'PGtsquery --> null 'PGint4
80 | numnode = unsafeFunction "numnode"
81 |
82 | -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` ignoring punctuation
83 | plainToTSquery :: null 'PGtext --> null 'PGtsquery
84 | plainToTSquery = unsafeFunction "plainto_tsquery"
85 |
86 | -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` that searches for a phrase,
87 | -- ignoring punctuation
88 | phraseToTSquery :: null 'PGtext --> null 'PGtsquery
89 | phraseToTSquery = unsafeFunction "phraseto_tsquery"
90 |
91 | -- | produce `Squeal.PostgreSQL.Expression.Type.tsquery` from a web search style query
92 | websearchToTSquery :: null 'PGtext --> null 'PGtsquery
93 | websearchToTSquery = unsafeFunction "websearch_to_tsquery"
94 |
95 | -- | get indexable part of a `Squeal.PostgreSQL.Expression.Type.tsquery`
96 | queryTree :: null 'PGtsquery --> null 'PGtext
97 | queryTree = unsafeFunction "query_tree"
98 |
99 | -- | normalize words and convert to `Squeal.PostgreSQL.Expression.Type.tsquery`
100 | toTSquery :: null 'PGtext --> null 'PGtsquery
101 | toTSquery = unsafeFunction "to_tsquery"
102 |
103 | -- | reduce document text to `Squeal.PostgreSQL.Expression.Type.tsvector`
104 | toTSvector
105 | :: ty `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
106 | => null ty --> null 'PGtsvector
107 | toTSvector = unsafeFunction "to_tsvector"
108 |
109 | -- | assign weight to each element of `Squeal.PostgreSQL.Expression.Type.tsvector`
110 | setWeight :: '[null 'PGtsvector, null ('PGchar 1)] ---> null 'PGtsvector
111 | setWeight = unsafeFunctionN "set_weight"
112 |
113 | -- | remove positions and weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
114 | strip :: null 'PGtsvector --> null 'PGtsvector
115 | strip = unsafeFunction "strip"
116 |
117 | -- | @jsonToTSvector (document *: filter)@
118 | -- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
119 | -- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
120 | -- filter is a `Squeal.PostgreSQL.Expression.Type.json` array, that enumerates what kind of elements
121 | -- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
122 | -- Possible values for filter are "string" (to include all string values),
123 | -- "numeric" (to include all numeric values in the string format),
124 | -- "boolean" (to include all Boolean values in the string format "true"/"false"),
125 | -- "key" (to include all keys) or "all" (to include all above).
126 | -- These values can be combined together to include, e.g. all string and numeric values.
127 | jsonToTSvector :: '[null 'PGjson, null 'PGjson] ---> null 'PGtsvector
128 | jsonToTSvector = unsafeFunctionN "json_to_tsvector"
129 |
130 | -- | @jsonbToTSvector (document *: filter)@
131 | -- reduce each value in the document, specified by filter to a `Squeal.PostgreSQL.Expression.Type.tsvector`,
132 | -- and then concatenate those in document order to produce a single `Squeal.PostgreSQL.Expression.Type.tsvector`.
133 | -- filter is a `Squeal.PostgreSQL.Expression.Type.jsonb` array, that enumerates what kind of elements
134 | -- need to be included into the resulting `Squeal.PostgreSQL.Expression.Type.tsvector`.
135 | -- Possible values for filter are "string" (to include all string values),
136 | -- "numeric" (to include all numeric values in the string format),
137 | -- "boolean" (to include all Boolean values in the string format "true"/"false"),
138 | -- "key" (to include all keys) or "all" (to include all above).
139 | -- These values can be combined together to include, e.g. all string and numeric values.
140 | jsonbToTSvector :: '[null 'PGjsonb, null 'PGjsonb] ---> null 'PGtsvector
141 | jsonbToTSvector = unsafeFunctionN "jsonb_to_tsvector"
142 |
143 | -- | remove given lexeme from `Squeal.PostgreSQL.Expression.Type.tsvector`
144 | tsDelete ::
145 | '[null 'PGtsvector, null ('PGvararray ('NotNull 'PGtext))]
146 | ---> null 'PGtsvector
147 | tsDelete = unsafeFunctionN "ts_delete"
148 |
149 | -- | select only elements with given weights from `Squeal.PostgreSQL.Expression.Type.tsvector`
150 | tsFilter ::
151 | '[null 'PGtsvector, null ('PGvararray ('NotNull ('PGchar 1)))]
152 | ---> null 'PGtsvector
153 | tsFilter = unsafeFunctionN "ts_filter"
154 |
155 | -- | display a `Squeal.PostgreSQL.Expression.Type.tsquery` match
156 | tsHeadline
157 | :: document `In` '[ 'PGtext, 'PGjson, 'PGjsonb]
158 | => '[null document, null 'PGtsquery] ---> null 'PGtext
159 | tsHeadline = unsafeFunctionN "ts_headline"
160 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Expression/Time.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Expression.Time
3 | Description: date/time functions and operators
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | date/time functions and operators
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , DeriveGeneric
14 | , FunctionalDependencies
15 | , LambdaCase
16 | , MultiParamTypeClasses
17 | , OverloadedStrings
18 | , PolyKinds
19 | , RankNTypes
20 | , TypeFamilies
21 | , TypeOperators
22 | , UndecidableInstances
23 | #-}
24 |
25 | module Squeal.PostgreSQL.Expression.Time
26 | ( -- * Time Operation
27 | TimeOp (..)
28 | -- * Time Function
29 | , currentDate
30 | , currentTime
31 | , currentTimestamp
32 | , dateTrunc
33 | , localTime
34 | , localTimestamp
35 | , now
36 | , makeDate
37 | , makeTime
38 | , makeTimestamp
39 | , makeTimestamptz
40 | , atTimeZone
41 | , PGAtTimeZone
42 | -- * Interval
43 | , interval_
44 | , TimeUnit (..)
45 | ) where
46 |
47 | import Data.Fixed
48 | import Data.String
49 | import GHC.TypeLits
50 |
51 | import qualified GHC.Generics as GHC
52 | import qualified Generics.SOP as SOP
53 |
54 | import Squeal.PostgreSQL.Expression
55 | import Squeal.PostgreSQL.Render
56 | import Squeal.PostgreSQL.Type.List
57 | import Squeal.PostgreSQL.Type.Schema
58 |
59 | -- $setup
60 | -- >>> import Squeal.PostgreSQL
61 |
62 | -- | >>> printSQL currentDate
63 | -- CURRENT_DATE
64 | currentDate :: Expr (null 'PGdate)
65 | currentDate = UnsafeExpression "CURRENT_DATE"
66 |
67 | -- | >>> printSQL currentTime
68 | -- CURRENT_TIME
69 | currentTime :: Expr (null 'PGtimetz)
70 | currentTime = UnsafeExpression "CURRENT_TIME"
71 |
72 | -- | >>> printSQL currentTimestamp
73 | -- CURRENT_TIMESTAMP
74 | currentTimestamp :: Expr (null 'PGtimestamptz)
75 | currentTimestamp = UnsafeExpression "CURRENT_TIMESTAMP"
76 |
77 | -- | >>> printSQL localTime
78 | -- LOCALTIME
79 | localTime :: Expr (null 'PGtime)
80 | localTime = UnsafeExpression "LOCALTIME"
81 |
82 | -- | >>> printSQL localTimestamp
83 | -- LOCALTIMESTAMP
84 | localTimestamp :: Expr (null 'PGtimestamp)
85 | localTimestamp = UnsafeExpression "LOCALTIMESTAMP"
86 |
87 | -- | Current date and time (equivalent to `currentTimestamp`)
88 | --
89 | -- >>> printSQL now
90 | -- now()
91 | now :: Expr (null 'PGtimestamptz)
92 | now = UnsafeExpression "now()"
93 |
94 | {-|
95 | Create date from year, month and day fields
96 |
97 | >>> printSQL (makeDate (1984 :* 7 *: 3))
98 | make_date((1984 :: int4), (7 :: int4), (3 :: int4))
99 | -}
100 | makeDate :: '[ null 'PGint4, null 'PGint4, null 'PGint4 ] ---> null 'PGdate
101 | makeDate = unsafeFunctionN "make_date"
102 |
103 | {-|
104 | Create time from hour, minute and seconds fields
105 |
106 | >>> printSQL (makeTime (8 :* 15 *: 23.5))
107 | make_time((8 :: int4), (15 :: int4), (23.5 :: float8))
108 | -}
109 | makeTime :: '[ null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtime
110 | makeTime = unsafeFunctionN "make_time"
111 |
112 | {-|
113 | Create timestamp from year, month, day, hour, minute and seconds fields
114 |
115 | >>> printSQL (makeTimestamp (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
116 | make_timestamp((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8))
117 | -}
118 | makeTimestamp ::
119 | '[ null 'PGint4, null 'PGint4, null 'PGint4
120 | , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamp
121 | makeTimestamp = unsafeFunctionN "make_timestamp"
122 |
123 | {-|
124 | Create timestamp with time zone from
125 | year, month, day, hour, minute and seconds fields;
126 | the current time zone is used
127 |
128 | >>> printSQL (makeTimestamptz (2013 :* 7 :* 15 :* 8 :* 15 *: 23.5))
129 | make_timestamptz((2013 :: int4), (7 :: int4), (15 :: int4), (8 :: int4), (15 :: int4), (23.5 :: float8))
130 | -}
131 | makeTimestamptz ::
132 | '[ null 'PGint4, null 'PGint4, null 'PGint4
133 | , null 'PGint4, null 'PGint4, null 'PGfloat8 ] ---> null 'PGtimestamptz
134 | makeTimestamptz = unsafeFunctionN "make_timestamptz"
135 |
136 | {-|
137 | Truncate a timestamp with the specified precision
138 |
139 | >>> printSQL $ dateTrunc Quarter (makeTimestamp (2010 :* 5 :* 6 :* 14 :* 45 *: 11.4))
140 | date_trunc('quarter', make_timestamp((2010 :: int4), (5 :: int4), (6 :: int4), (14 :: int4), (45 :: int4), (11.4 :: float8)))
141 | -}
142 | dateTrunc
143 | :: time `In` '[ 'PGtimestamp, 'PGtimestamptz ]
144 | => TimeUnit -> null time --> null time
145 | dateTrunc tUnit args = unsafeFunctionN "date_trunc" (timeUnitExpr *: args)
146 | where
147 | timeUnitExpr :: forall grp lat with db params from null0.
148 | Expression grp lat with db params from (null0 'PGtext)
149 | timeUnitExpr = UnsafeExpression . singleQuotedUtf8 . renderSQL $ tUnit
150 |
151 | -- | Calculate the return time type of the `atTimeZone` `Operator`.
152 | type family PGAtTimeZone ty where
153 | PGAtTimeZone 'PGtimestamptz = 'PGtimestamp
154 | PGAtTimeZone 'PGtimestamp = 'PGtimestamptz
155 | PGAtTimeZone 'PGtimetz = 'PGtimetz
156 | PGAtTimeZone pg = TypeError
157 | ( 'Text "Squeal type error: AT TIME ZONE cannot be applied to "
158 | ':<>: 'ShowType pg )
159 |
160 | {-|
161 | Convert a timestamp, timestamp with time zone, or time of day with timezone to a different timezone using an interval offset or specific timezone denoted by text. When using the interval offset, the interval duration must be less than one day or 24 hours.
162 |
163 | >>> printSQL $ (makeTimestamp (2009 :* 7 :* 22 :* 19 :* 45 *: 11.4)) `atTimeZone` (interval_ 8 Hours)
164 | (make_timestamp((2009 :: int4), (7 :: int4), (22 :: int4), (19 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (INTERVAL '8.000 hours'))
165 |
166 | >>> :{
167 | let
168 | timezone :: Expr (null 'PGtext)
169 | timezone = "EST"
170 | in printSQL $ (makeTimestamptz (2015 :* 9 :* 15 :* 4 :* 45 *: 11.4)) `atTimeZone` timezone
171 | :}
172 | (make_timestamptz((2015 :: int4), (9 :: int4), (15 :: int4), (4 :: int4), (45 :: int4), (11.4 :: float8)) AT TIME ZONE (E'EST' :: text))
173 | -}
174 | atTimeZone
175 | :: zone `In` '[ 'PGtext, 'PGinterval]
176 | => Operator (null time) (null zone) (null (PGAtTimeZone time))
177 | atTimeZone = unsafeBinaryOp "AT TIME ZONE"
178 |
179 | {-|
180 | Affine space operations on time types.
181 | -}
182 | class TimeOp time diff | time -> diff where
183 | {-|
184 | >>> printSQL (makeDate (1984 :* 7 *: 3) !+ 365)
185 | (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) + (365 :: int4))
186 | -}
187 | (!+) :: Operator (null time) (null diff) (null time)
188 | (!+) = unsafeBinaryOp "+"
189 | {-|
190 | >>> printSQL (365 +! makeDate (1984 :* 7 *: 3))
191 | ((365 :: int4) + make_date((1984 :: int4), (7 :: int4), (3 :: int4)))
192 | -}
193 | (+!) :: Operator (null diff) (null time) (null time)
194 | (+!) = unsafeBinaryOp "+"
195 | {-|
196 | >>> printSQL (makeDate (1984 :* 7 *: 3) !- 365)
197 | (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - (365 :: int4))
198 | -}
199 | (!-) :: Operator (null time) (null diff) (null time)
200 | (!-) = unsafeBinaryOp "-"
201 | {-|
202 | >>> printSQL (makeDate (1984 :* 7 *: 3) !-! currentDate)
203 | (make_date((1984 :: int4), (7 :: int4), (3 :: int4)) - CURRENT_DATE)
204 | -}
205 | (!-!) :: Operator (null time) (null time) (null diff)
206 | (!-!) = unsafeBinaryOp "-"
207 | instance TimeOp 'PGtimestamp 'PGinterval
208 | instance TimeOp 'PGtimestamptz 'PGinterval
209 | instance TimeOp 'PGtime 'PGinterval
210 | instance TimeOp 'PGtimetz 'PGinterval
211 | instance TimeOp 'PGinterval 'PGinterval
212 | instance TimeOp 'PGdate 'PGint4
213 | infixl 6 !+
214 | infixl 6 +!
215 | infixl 6 !-
216 | infixl 6 !-!
217 |
218 | -- | A `TimeUnit` to use in `interval_` construction.
219 | data TimeUnit
220 | = Years | Quarter | Months | Weeks | Days
221 | | Hours | Minutes | Seconds
222 | | Microseconds | Milliseconds
223 | | Decades | Centuries | Millennia
224 | deriving (Eq, Ord, Show, Read, Enum, GHC.Generic)
225 | instance SOP.Generic TimeUnit
226 | instance SOP.HasDatatypeInfo TimeUnit
227 | instance RenderSQL TimeUnit where
228 | renderSQL = \case
229 | Years -> "years"
230 | Quarter -> "quarter"
231 | Months -> "months"
232 | Weeks -> "weeks"
233 | Days -> "days"
234 | Hours -> "hours"
235 | Minutes -> "minutes"
236 | Seconds -> "seconds"
237 | Microseconds -> "microseconds"
238 | Milliseconds -> "milliseconds"
239 | Decades -> "decades"
240 | Centuries -> "centuries"
241 | Millennia -> "millennia"
242 |
243 | -- | >>> printSQL $ interval_ 7 Days
244 | -- (INTERVAL '7.000 days')
245 | interval_ :: Milli -> TimeUnit -> Expr (null 'PGinterval)
246 | interval_ num unit = UnsafeExpression . parenthesized $ "INTERVAL" <+>
247 | "'" <> fromString (show num) <+> renderSQL unit <> "'"
248 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Call.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Call
3 | Description: call statements
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | call statements
9 | -}
10 |
11 | {-# LANGUAGE
12 | DeriveGeneric
13 | , DerivingStrategies
14 | , FlexibleContexts
15 | , FlexibleInstances
16 | , GADTs
17 | , GeneralizedNewtypeDeriving
18 | , LambdaCase
19 | , MultiParamTypeClasses
20 | , OverloadedStrings
21 | , PatternSynonyms
22 | , QuantifiedConstraints
23 | , RankNTypes
24 | , ScopedTypeVariables
25 | , TypeApplications
26 | , TypeFamilies
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableInstances
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Manipulation.Call
34 | ( -- * Call
35 | call
36 | , unsafeCall
37 | , callN
38 | , unsafeCallN
39 | ) where
40 |
41 | import Data.ByteString hiding (foldr)
42 |
43 | import Generics.SOP (SListI)
44 |
45 | import Squeal.PostgreSQL.Type.Alias
46 | import Squeal.PostgreSQL.Expression
47 | import Squeal.PostgreSQL.Manipulation
48 | import Squeal.PostgreSQL.Type.List
49 | import Squeal.PostgreSQL.Render
50 | import Squeal.PostgreSQL.Type.Schema
51 |
52 | -- $setup
53 | -- >>> import Squeal.PostgreSQL
54 |
55 | {- |
56 | >>> printSQL $ unsafeCall "p" true
57 | CALL p(TRUE)
58 | -}
59 | unsafeCall
60 | :: ByteString -- ^ procedure to call
61 | -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments
62 | -> Manipulation with db params '[]
63 | unsafeCall pro x = UnsafeManipulation $
64 | "CALL" <+> pro <> parenthesized (renderSQL x)
65 |
66 | {- | Call a user defined procedure of one variable.
67 |
68 | >>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4 ] ]
69 | >>> :{
70 | let
71 | p :: Manipulation '[] (Public Schema) '[] '[]
72 | p = call #p 1
73 | in
74 | printSQL p
75 | :}
76 | CALL "p"((1 :: int4))
77 | -}
78 | call
79 | :: ( Has sch db schema
80 | , Has pro schema ('Procedure '[x]) )
81 | => QualifiedAlias sch pro -- ^ procedure to call
82 | -> Expression 'Ungrouped '[] with db params '[] x -- ^ arguments
83 | -> Manipulation with db params '[]
84 | call = unsafeCall . renderSQL
85 |
86 |
87 | {- |
88 | >>> printSQL $ unsafeCallN "p" (true *: false)
89 | CALL p(TRUE, FALSE)
90 | -}
91 | unsafeCallN
92 | :: SListI xs
93 | => ByteString -- ^ procedure to call
94 | -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments
95 | -> Manipulation with db params '[]
96 | unsafeCallN pro xs = UnsafeManipulation $
97 | "CALL" <+> pro <> parenthesized (renderCommaSeparated renderSQL xs)
98 |
99 | {- | Call a user defined procedure.
100 |
101 | >>> type Schema = '[ "p" ::: 'Procedure '[ 'NotNull 'PGint4, 'NotNull 'PGtext ] ]
102 | >>> :{
103 | let
104 | p :: Manipulation '[] (Public Schema) '[] '[]
105 | p = callN #p (1 *: "hi")
106 | in
107 | printSQL p
108 | :}
109 | CALL "p"((1 :: int4), (E'hi' :: text))
110 | -}
111 | callN
112 | :: ( Has sch db schema
113 | , Has pro schema ('Procedure xs)
114 | , SListI xs )
115 | => QualifiedAlias sch pro -- ^ procedure to call
116 | -> NP (Expression 'Ungrouped '[] with db params '[]) xs -- ^ arguments
117 | -> Manipulation with db params '[]
118 | callN = unsafeCallN . renderSQL
119 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Delete.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Delete
3 | Description: delete statements
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | delete statements
9 | -}
10 |
11 | {-# LANGUAGE
12 | DeriveGeneric
13 | , DerivingStrategies
14 | , FlexibleContexts
15 | , FlexibleInstances
16 | , GADTs
17 | , GeneralizedNewtypeDeriving
18 | , LambdaCase
19 | , MultiParamTypeClasses
20 | , OverloadedStrings
21 | , PatternSynonyms
22 | , QuantifiedConstraints
23 | , RankNTypes
24 | , ScopedTypeVariables
25 | , TypeApplications
26 | , TypeFamilies
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableInstances
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Manipulation.Delete
34 | ( -- * Delete
35 | deleteFrom
36 | , deleteFrom_
37 | ) where
38 |
39 | import qualified Generics.SOP as SOP
40 |
41 | import Squeal.PostgreSQL.Type.Alias
42 | import Squeal.PostgreSQL.Expression.Logic
43 | import Squeal.PostgreSQL.Manipulation
44 | import Squeal.PostgreSQL.Type.List
45 | import Squeal.PostgreSQL.Render
46 | import Squeal.PostgreSQL.Type.Schema
47 |
48 | -- $setup
49 | -- >>> import Squeal.PostgreSQL
50 |
51 | {-----------------------------------------
52 | DELETE statements
53 | -----------------------------------------}
54 |
55 | {- | Delete rows from a table.
56 |
57 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
58 | >>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)]
59 | >>> :{
60 | let
61 | manp :: Manipulation with (Public Schema) '[] '["col1" ::: 'NotNull 'PGint4, "col2" ::: 'NotNull 'PGint4]
62 | manp = deleteFrom #tab1 (Using (table #tab2)) (#tab1 ! #col1 .== #tab2 ! #col2) (Returning (#tab1 & DotStar))
63 | in printSQL manp
64 | :}
65 | DELETE FROM "tab1" AS "tab1" USING "tab2" AS "tab2" WHERE ("tab1"."col1" = "tab2"."col2") RETURNING "tab1".*
66 | -}
67 | deleteFrom
68 | :: ( SOP.SListI row
69 | , Has sch db schema
70 | , Has tab0 schema ('Table table) )
71 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from
72 | -> UsingClause with db params from
73 | -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)
74 | -- ^ condition under which to delete a row
75 | -> ReturningClause with db params (tab ::: TableToRow table ': from) row
76 | -- ^ results to return
77 | -> Manipulation with db params row
78 | deleteFrom (tab0 `As` tab) using wh returning = UnsafeManipulation $
79 | "DELETE FROM"
80 | <+> renderSQL tab0 <+> "AS" <+> renderSQL tab
81 | <> case using of
82 | NoUsing -> ""
83 | Using tables -> " USING" <+> renderSQL tables
84 | <+> "WHERE" <+> renderSQL wh
85 | <> renderSQL returning
86 |
87 | {- | Delete rows returning `Nil`.
88 |
89 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4]
90 | >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
91 | >>> :{
92 | let
93 | manp :: Manipulation with (Public Schema) '[ 'NotNull 'PGint4] '[]
94 | manp = deleteFrom_ (#tab `as` #t) (#t ! #col1 .== param @1)
95 | in printSQL manp
96 | :}
97 | DELETE FROM "tab" AS "t" WHERE ("t"."col1" = ($1 :: int4))
98 | -}
99 | deleteFrom_
100 | :: ( Has sch db schema
101 | , Has tab0 schema ('Table table) )
102 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to delete from
103 | -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table]
104 | -- ^ condition under which to delete a row
105 | -> Manipulation with db params '[]
106 | deleteFrom_ tab wh = deleteFrom tab NoUsing wh (Returning_ Nil)
107 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Manipulation/Update.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Update
3 | Description: update statements
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | update statements
9 | -}
10 |
11 | {-# LANGUAGE
12 | DeriveGeneric
13 | , DerivingStrategies
14 | , FlexibleContexts
15 | , FlexibleInstances
16 | , GADTs
17 | , GeneralizedNewtypeDeriving
18 | , LambdaCase
19 | , MultiParamTypeClasses
20 | , OverloadedStrings
21 | , PatternSynonyms
22 | , QuantifiedConstraints
23 | , RankNTypes
24 | , ScopedTypeVariables
25 | , TypeApplications
26 | , TypeFamilies
27 | , DataKinds
28 | , PolyKinds
29 | , TypeOperators
30 | , UndecidableInstances
31 | #-}
32 |
33 | module Squeal.PostgreSQL.Manipulation.Update
34 | ( -- * Update
35 | update
36 | , update_
37 | ) where
38 |
39 | import Data.ByteString hiding (foldr)
40 | import GHC.TypeLits
41 |
42 | import qualified Generics.SOP as SOP
43 |
44 | import Squeal.PostgreSQL.Type.Alias
45 | import Squeal.PostgreSQL.Expression
46 | import Squeal.PostgreSQL.Expression.Default
47 | import Squeal.PostgreSQL.Expression.Logic
48 | import Squeal.PostgreSQL.Manipulation
49 | import Squeal.PostgreSQL.Type.List
50 | import Squeal.PostgreSQL.Render
51 | import Squeal.PostgreSQL.Type.Schema
52 |
53 | -- $setup
54 | -- >>> import Squeal.PostgreSQL
55 |
56 | renderUpdate
57 | :: (forall x. RenderSQL (expr x))
58 | => Aliased (Optional expr) ty
59 | -> ByteString
60 | renderUpdate (expr `As` col) = renderSQL col <+> "=" <+> renderSQL expr
61 |
62 | {-----------------------------------------
63 | UPDATE statements
64 | -----------------------------------------}
65 |
66 | {- | An `update` command changes the values of the specified columns
67 | in all rows that satisfy the condition.
68 |
69 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
70 | >>> type Schema = '["tab1" ::: 'Table ('[] :=> Columns), "tab2" ::: 'Table ('[] :=> Columns)]
71 | >>> :{
72 | let
73 | manp :: Manipulation with (Public Schema) '[]
74 | '["col1" ::: 'NotNull 'PGint4,
75 | "col2" ::: 'NotNull 'PGint4]
76 | manp = update
77 | (#tab1 `as` #t1)
78 | (Set (2 + #t2 ! #col2) `as` #col1)
79 | (Using (table (#tab2 `as` #t2)))
80 | (#t1 ! #col1 ./= #t2 ! #col2)
81 | (Returning (#t1 & DotStar))
82 | in printSQL manp
83 | :}
84 | UPDATE "tab1" AS "t1" SET "col1" = ((2 :: int4) + "t2"."col2") FROM "tab2" AS "t2" WHERE ("t1"."col1" <> "t2"."col2") RETURNING "t1".*
85 | -}
86 | update
87 | :: ( Has sch db schema
88 | , Has tab0 schema ('Table table)
89 | , Updatable table updates
90 | , SOP.SListI row )
91 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update
92 | -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)))) updates
93 | -- ^ update expressions, modified values to replace old values
94 | -> UsingClause with db params from
95 | -- ^ FROM A table expression allowing columns from other tables to appear
96 | -- in the WHERE condition and update expressions.
97 | -> Condition 'Ungrouped '[] with db params (tab ::: TableToRow table ': from)
98 | -- ^ WHERE condition under which to perform update on a row
99 | -> ReturningClause with db params (tab ::: TableToRow table ': from) row -- ^ results to return
100 | -> Manipulation with db params row
101 | update (tab0 `As` tab) columns using wh returning = UnsafeManipulation $
102 | "UPDATE"
103 | <+> renderSQL tab0 <+> "AS" <+> renderSQL tab
104 | <+> "SET"
105 | <+> renderCommaSeparated renderUpdate columns
106 | <> case using of
107 | NoUsing -> ""
108 | Using tables -> " FROM" <+> renderSQL tables
109 | <+> "WHERE" <+> renderSQL wh
110 | <> renderSQL returning
111 |
112 | {- | Update a row returning `Nil`.
113 |
114 | >>> type Columns = '["col1" ::: 'Def :=> 'NotNull 'PGint4, "col2" ::: 'NoDef :=> 'NotNull 'PGint4]
115 | >>> type Schema = '["tab" ::: 'Table ('[] :=> Columns)]
116 | >>> :{
117 | let
118 | manp :: Manipulation with (Public Schema) '[] '[]
119 | manp = update_ #tab (Set 2 `as` #col1) (#col1 ./= #col2)
120 | in printSQL manp
121 | :}
122 | UPDATE "tab" AS "tab" SET "col1" = (2 :: int4) WHERE ("col1" <> "col2")
123 | -}
124 | update_
125 | :: ( Has sch db schema
126 | , Has tab0 schema ('Table table)
127 | , KnownSymbol tab
128 | , Updatable table updates )
129 | => Aliased (QualifiedAlias sch) (tab ::: tab0) -- ^ table to update
130 | -> NP (Aliased (Optional (Expression 'Ungrouped '[] with db params '[tab ::: TableToRow table]))) updates
131 | -- ^ modified values to replace old values
132 | -> Condition 'Ungrouped '[] with db params '[tab ::: TableToRow table]
133 | -- ^ condition under which to perform update on a row
134 | -> Manipulation with db params '[]
135 | update_ tab columns wh = update tab columns NoUsing wh (Returning_ Nil)
136 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Query/From.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Query.From
3 | Description: from clauses
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | from clauses
9 | -}
10 |
11 | {-# LANGUAGE
12 | ConstraintKinds
13 | , DeriveGeneric
14 | , DerivingStrategies
15 | , FlexibleContexts
16 | , FlexibleInstances
17 | , GADTs
18 | , GeneralizedNewtypeDeriving
19 | , LambdaCase
20 | , MultiParamTypeClasses
21 | , OverloadedLabels
22 | , OverloadedStrings
23 | , QuantifiedConstraints
24 | , ScopedTypeVariables
25 | , StandaloneDeriving
26 | , TypeApplications
27 | , TypeFamilies
28 | , DataKinds
29 | , PolyKinds
30 | , TypeOperators
31 | , RankNTypes
32 | , UndecidableInstances
33 | #-}
34 |
35 | module Squeal.PostgreSQL.Query.From
36 | ( -- * From Clause
37 | FromClause (..)
38 | , table
39 | , subquery
40 | , view
41 | , common
42 | ) where
43 |
44 | import Control.DeepSeq
45 | import Data.ByteString (ByteString)
46 |
47 | import qualified GHC.Generics as GHC
48 |
49 | import Squeal.PostgreSQL.Type.Alias
50 | import Squeal.PostgreSQL.Query
51 | import Squeal.PostgreSQL.Render
52 | import Squeal.PostgreSQL.Type.List
53 | import Squeal.PostgreSQL.Type.Schema
54 |
55 | -- $setup
56 | -- >>> import Squeal.PostgreSQL
57 |
58 | {-----------------------------------------
59 | FROM clauses
60 | -----------------------------------------}
61 |
62 | {- |
63 | A `FromClause` can be a table name, or a derived table such
64 | as a subquery, a @JOIN@ construct, or complex combinations of these.
65 | -}
66 | newtype FromClause
67 | (lat :: FromType)
68 | (with :: FromType)
69 | (db :: SchemasType)
70 | (params :: [NullType])
71 | (from :: FromType)
72 | = UnsafeFromClause { renderFromClause :: ByteString }
73 | deriving stock (GHC.Generic,Show,Eq,Ord)
74 | deriving newtype (NFData)
75 | instance RenderSQL (FromClause lat with db params from) where
76 | renderSQL = renderFromClause
77 |
78 | -- | A real `table` is a table from the database.
79 | table
80 | :: (Has sch db schema, Has tab schema ('Table table))
81 | => Aliased (QualifiedAlias sch) (alias ::: tab) -- ^ (renamable) table alias
82 | -> FromClause lat with db params '[alias ::: TableToRow table]
83 | table (tab `As` alias) = UnsafeFromClause $
84 | renderSQL tab <+> "AS" <+> renderSQL alias
85 |
86 | {- | `subquery` derives a table from a `Query`.
87 | The subquery may not reference columns provided by preceding `FromClause` items.
88 | Use `Squeal.PostgreSQL.Query.From.Join.JoinLateral`
89 | if the subquery must reference columns provided by preceding `FromClause` items.
90 | -}
91 | subquery
92 | :: Aliased (Query lat with db params) query
93 | -- ^ aliased `Query`
94 | -> FromClause lat with db params '[query]
95 | subquery = UnsafeFromClause . renderAliased (parenthesized . renderSQL)
96 |
97 | -- | `view` derives a table from a `View`.
98 | view
99 | :: (Has sch db schema, Has vw schema ('View view))
100 | => Aliased (QualifiedAlias sch) (alias ::: vw) -- ^ (renamable) view alias
101 | -> FromClause lat with db params '[alias ::: view]
102 | view (vw `As` alias) = UnsafeFromClause $
103 | renderSQL vw <+> "AS" <+> renderSQL alias
104 |
105 | -- | `common` derives a table from a common table expression.
106 | common
107 | :: Has cte with common
108 | => Aliased Alias (alias ::: cte) -- ^ (renamable) common table expression alias
109 | -> FromClause lat with db params '[alias ::: common]
110 | common (cte `As` alias) = UnsafeFromClause $
111 | renderSQL cte <+> "AS" <+> renderSQL alias
112 |
113 | instance Additional (FromClause lat with db params) where
114 | also right left = UnsafeFromClause $
115 | renderSQL left <> ", " <> renderSQL right
116 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Query/From/Set.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Query.From.Set
3 | Description: set returning functions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | set returning functions
9 | -}
10 |
11 | {-# LANGUAGE
12 | ConstraintKinds
13 | , DeriveGeneric
14 | , DerivingStrategies
15 | , FlexibleContexts
16 | , FlexibleInstances
17 | , GADTs
18 | , GeneralizedNewtypeDeriving
19 | , LambdaCase
20 | , MultiParamTypeClasses
21 | , OverloadedLabels
22 | , OverloadedStrings
23 | , QuantifiedConstraints
24 | , ScopedTypeVariables
25 | , StandaloneDeriving
26 | , TypeApplications
27 | , TypeFamilies
28 | , DataKinds
29 | , PolyKinds
30 | , TypeOperators
31 | , RankNTypes
32 | , UndecidableInstances
33 | #-}
34 |
35 | module Squeal.PostgreSQL.Query.From.Set
36 | ( -- * Set Functions
37 | type (-|->)
38 | , type (--|->)
39 | , SetFun
40 | , SetFunN
41 | , generateSeries
42 | , generateSeriesStep
43 | , generateSeriesTimestamp
44 | , unsafeSetFunction
45 | , setFunction
46 | , unsafeSetFunctionN
47 | , setFunctionN
48 | ) where
49 |
50 | import Data.ByteString (ByteString)
51 | import Generics.SOP hiding (from)
52 | import GHC.TypeLits
53 |
54 | import qualified Generics.SOP as SOP
55 |
56 | import Squeal.PostgreSQL.Type.Alias
57 | import Squeal.PostgreSQL.Expression
58 | import Squeal.PostgreSQL.Query.From
59 | import Squeal.PostgreSQL.Render
60 | import Squeal.PostgreSQL.Type.List
61 | import Squeal.PostgreSQL.Type.Schema
62 |
63 | {- |
64 | A @RankNType@ for set returning functions with 1 argument.
65 | -}
66 | type (-|->) arg set = forall db. SetFun db arg set
67 |
68 | {- |
69 | A @RankNType@ for set returning functions with multiple argument.
70 | -}
71 | type (--|->) arg set = forall db. SetFunN db arg set
72 | -- ^ output
73 |
74 | {- |
75 | Like `-|->` but depends on the schemas of the database
76 | -}
77 | type SetFun db arg row
78 | = forall lat with params
79 | . Expression 'Ungrouped lat with db params '[] arg
80 | -- ^ input
81 | -> FromClause lat with db params '[row]
82 | -- ^ output
83 |
84 | {- |
85 | Like `--|->` but depends on the schemas of the database
86 | -}
87 | type SetFunN db args set
88 | = forall lat with params
89 | . NP (Expression 'Ungrouped lat with db params '[]) args
90 | -- ^ input
91 | -> FromClause lat with db params '[set]
92 | -- ^ output
93 |
94 | -- $setup
95 | -- >>> import Squeal.PostgreSQL
96 |
97 | -- | Escape hatch for a set returning function of a single variable
98 | unsafeSetFunction
99 | :: forall fun ty row. KnownSymbol fun
100 | => ByteString
101 | -> ty -|-> (fun ::: row) -- ^ set returning function
102 | unsafeSetFunction fun x = UnsafeFromClause $
103 | fun <> parenthesized (renderSQL x)
104 |
105 | {- | Call a user defined set returning function of a single variable
106 |
107 | >>> type Fn = '[ 'Null 'PGbool] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric]
108 | >>> type Schema = '["fn" ::: 'Function Fn]
109 | >>> :{
110 | let
111 | fn :: SetFun (Public Schema) ('Null 'PGbool) ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric])
112 | fn = setFunction #fn
113 | in
114 | printSQL (fn true)
115 | :}
116 | "fn"(TRUE)
117 | -}
118 | setFunction
119 | :: ( Has sch db schema
120 | , Has fun schema ('Function ('[ty] :=> 'ReturnsTable row)) )
121 | => QualifiedAlias sch fun -- ^ function alias
122 | -> SetFun db ty (fun ::: row)
123 | setFunction fun = unsafeSetFunction (renderSQL fun)
124 |
125 | {- | Escape hatch for a multivariable set returning function-}
126 | unsafeSetFunctionN
127 | :: forall fun tys row. (SOP.SListI tys, KnownSymbol fun)
128 | => ByteString
129 | -> tys --|-> (fun ::: row) -- ^ set returning function
130 | unsafeSetFunctionN fun xs = UnsafeFromClause $
131 | fun <> parenthesized (renderCommaSeparated renderSQL xs)
132 |
133 | {- | Call a user defined multivariable set returning function
134 |
135 | >>> type Fn = '[ 'Null 'PGbool, 'Null 'PGtext] :=> 'ReturnsTable '["ret" ::: 'NotNull 'PGnumeric]
136 | >>> type Schema = '["fn" ::: 'Function Fn]
137 | >>> :{
138 | let
139 | fn :: SetFunN (Public Schema)
140 | '[ 'Null 'PGbool, 'Null 'PGtext]
141 | ("fn" ::: '["ret" ::: 'NotNull 'PGnumeric])
142 | fn = setFunctionN #fn
143 | in
144 | printSQL (fn (true *: "hi"))
145 | :}
146 | "fn"(TRUE, (E'hi' :: text))
147 | -}
148 | setFunctionN
149 | :: ( Has sch db schema
150 | , Has fun schema ('Function (tys :=> 'ReturnsTable row))
151 | , SOP.SListI tys )
152 | => QualifiedAlias sch fun -- ^ function alias
153 | -> SetFunN db tys (fun ::: row)
154 | setFunctionN fun = unsafeSetFunctionN (renderSQL fun)
155 |
156 | {- | @generateSeries (start :* stop)@
157 |
158 | Generate a series of values,
159 | from @start@ to @stop@ with a step size of one
160 |
161 | >>> printSQL (generateSeries @'PGint4 (1 *: 10))
162 | generate_series((1 :: int4), (10 :: int4))
163 | -}
164 | generateSeries
165 | :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
166 | => '[ null ty, null ty] --|->
167 | ("generate_series" ::: '["generate_series" ::: null ty])
168 | -- ^ set returning function
169 | generateSeries = unsafeSetFunctionN "generate_series"
170 |
171 | {- | @generateSeriesStep (start :* stop *: step)@
172 |
173 | Generate a series of values,
174 | from @start@ to @stop@ with a step size of @step@
175 |
176 | >>> printSQL (generateSeriesStep @'PGint8 (2 :* 100 *: 2))
177 | generate_series((2 :: int8), (100 :: int8), (2 :: int8))
178 | -}
179 | generateSeriesStep
180 | :: ty `In` '[ 'PGint4, 'PGint8, 'PGnumeric]
181 | => '[null ty, null ty, null ty] --|->
182 | ("generate_series" ::: '["generate_series" ::: null ty])
183 | -- ^ set returning function
184 | generateSeriesStep = unsafeSetFunctionN "generate_series"
185 |
186 | {- | @generateSeriesTimestamp (start :* stop *: step)@
187 |
188 | Generate a series of timestamps,
189 | from @start@ to @stop@ with a step size of @step@
190 |
191 | >>> :{
192 | let
193 | start = now
194 | stop = now !+ interval_ 10 Years
195 | step = interval_ 1 Months
196 | in printSQL (generateSeriesTimestamp (start :* stop *: step))
197 | :}
198 | generate_series(now(), (now() + (INTERVAL '10.000 years')), (INTERVAL '1.000 months'))
199 | -}
200 | generateSeriesTimestamp
201 | :: ty `In` '[ 'PGtimestamp, 'PGtimestamptz]
202 | => '[null ty, null ty, null 'PGinterval] --|->
203 | ("generate_series" ::: '["generate_series" ::: null ty])
204 | -- ^ set returning function
205 | generateSeriesTimestamp = unsafeSetFunctionN "generate_series"
206 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Query/Values.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Query.Values
3 | Description: values statements
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | values statements
9 | -}
10 |
11 | {-# LANGUAGE
12 | ConstraintKinds
13 | , DeriveGeneric
14 | , DerivingStrategies
15 | , FlexibleContexts
16 | , FlexibleInstances
17 | , GADTs
18 | , GeneralizedNewtypeDeriving
19 | , LambdaCase
20 | , MultiParamTypeClasses
21 | , OverloadedLabels
22 | , OverloadedStrings
23 | , QuantifiedConstraints
24 | , ScopedTypeVariables
25 | , StandaloneDeriving
26 | , TypeApplications
27 | , TypeFamilies
28 | , DataKinds
29 | , PolyKinds
30 | , TypeOperators
31 | , RankNTypes
32 | , UndecidableInstances
33 | #-}
34 |
35 | module Squeal.PostgreSQL.Query.Values
36 | ( -- ** Values
37 | values
38 | , values_
39 | ) where
40 |
41 | import Data.ByteString (ByteString)
42 | import Generics.SOP hiding (from)
43 |
44 | import Squeal.PostgreSQL.Type.Alias
45 | import Squeal.PostgreSQL.Expression
46 | import Squeal.PostgreSQL.Query
47 | import Squeal.PostgreSQL.Render
48 |
49 | -- $setup
50 | -- >>> import Squeal.PostgreSQL
51 |
52 | -- | `values` computes a row value or set of row values
53 | -- specified by value expressions. It is most commonly used
54 | -- to generate a “constant table” within a larger command,
55 | -- but it can be used on its own.
56 | --
57 | -- >>> type Row = '["a" ::: 'NotNull 'PGint4, "b" ::: 'NotNull 'PGtext]
58 | -- >>> let query = values (1 `as` #a :* "one" `as` #b) [] :: Query lat with db '[] Row
59 | -- >>> printSQL query
60 | -- SELECT * FROM (VALUES ((1 :: int4), (E'one' :: text))) AS t ("a", "b")
61 | values
62 | :: SListI cols
63 | => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols
64 | -> [NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols]
65 | -- ^ When more than one row is specified, all the rows must
66 | -- must have the same number of elements
67 | -> Query lat with db params cols
68 | values rw rws = UnsafeQuery $ "SELECT * FROM"
69 | <+> parenthesized (
70 | "VALUES"
71 | <+> commaSeparated
72 | ( parenthesized
73 | . renderCommaSeparated renderValuePart <$> rw:rws )
74 | ) <+> "AS t"
75 | <+> parenthesized (renderCommaSeparated renderAliasPart rw)
76 | where
77 | renderAliasPart, renderValuePart
78 | :: Aliased (Expression 'Ungrouped lat with db params '[] ) ty -> ByteString
79 | renderAliasPart (_ `As` name) = renderSQL name
80 | renderValuePart (value `As` _) = renderSQL value
81 |
82 | -- | `values_` computes a row value or set of row values
83 | -- specified by value expressions.
84 | values_
85 | :: SListI cols
86 | => NP (Aliased (Expression 'Ungrouped lat with db params '[] )) cols
87 | -- ^ one row of values
88 | -> Query lat with db params cols
89 | values_ rw = values rw []
90 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Render.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Render
3 | Description: render functions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | render functions
9 | -}
10 |
11 | {-# LANGUAGE
12 | AllowAmbiguousTypes
13 | , ConstraintKinds
14 | , FlexibleContexts
15 | , LambdaCase
16 | , MagicHash
17 | , OverloadedStrings
18 | , PolyKinds
19 | , RankNTypes
20 | , ScopedTypeVariables
21 | , TypeApplications
22 | #-}
23 |
24 | module Squeal.PostgreSQL.Render
25 | ( -- * Render
26 | RenderSQL (..)
27 | , printSQL
28 | , escape
29 | , parenthesized
30 | , bracketed
31 | , (<+>)
32 | , commaSeparated
33 | , doubleQuoted
34 | , singleQuotedText
35 | , singleQuotedUtf8
36 | , escapeQuotedString
37 | , escapeQuotedText
38 | , renderCommaSeparated
39 | , renderCommaSeparatedConstraint
40 | , renderCommaSeparatedMaybe
41 | , renderNat
42 | , renderSymbol
43 | ) where
44 |
45 | import Control.Monad.IO.Class (MonadIO (..))
46 | import Data.ByteString (ByteString)
47 | import Data.Maybe (catMaybes)
48 | import Data.Text (Text)
49 | import Generics.SOP
50 | import GHC.Exts
51 | import GHC.TypeLits hiding (Text)
52 |
53 | import qualified Data.Text as Text
54 | import qualified Data.Text.Encoding as Text
55 | import qualified Data.ByteString as ByteString
56 | import qualified Data.ByteString.Char8 as Char8
57 |
58 | -- | Parenthesize a `ByteString`.
59 | parenthesized :: ByteString -> ByteString
60 | parenthesized str = "(" <> str <> ")"
61 |
62 | -- | Square bracket a `ByteString`
63 | bracketed :: ByteString -> ByteString
64 | bracketed str = "[" <> str <> "]"
65 |
66 | -- | Concatenate two `ByteString`s with a space between.
67 | (<+>) :: ByteString -> ByteString -> ByteString
68 | infixr 7 <+>
69 | str1 <+> str2 = str1 <> " " <> str2
70 |
71 | -- | Comma separate a list of `ByteString`s.
72 | commaSeparated :: [ByteString] -> ByteString
73 | commaSeparated = ByteString.intercalate ", "
74 |
75 | -- | Add double quotes around a `ByteString`.
76 | doubleQuoted :: ByteString -> ByteString
77 | doubleQuoted str = "\"" <> str <> "\""
78 |
79 | -- | Add single quotes around a `Text` and escape single quotes within it.
80 | singleQuotedText :: Text -> ByteString
81 | singleQuotedText str =
82 | "'" <> Text.encodeUtf8 (Text.replace "'" "''" str) <> "'"
83 |
84 | -- | Add single quotes around a `ByteString` and escape single quotes within it.
85 | singleQuotedUtf8 :: ByteString -> ByteString
86 | singleQuotedUtf8 = singleQuotedText . Text.decodeUtf8
87 |
88 | -- | Escape quote a string.
89 | escapeQuotedString :: String -> ByteString
90 | escapeQuotedString x = "E\'" <> Text.encodeUtf8 (fromString (escape =<< x)) <> "\'"
91 |
92 | -- | Escape quote a string.
93 | escapeQuotedText :: Text -> ByteString
94 | escapeQuotedText x =
95 | "E\'" <> Text.encodeUtf8 (Text.concatMap (fromString . escape) x) <> "\'"
96 |
97 | -- | Comma separate the renderings of a heterogeneous list.
98 | renderCommaSeparated
99 | :: SListI xs
100 | => (forall x. expression x -> ByteString)
101 | -> NP expression xs -> ByteString
102 | renderCommaSeparated render
103 | = commaSeparated
104 | . hcollapse
105 | . hmap (K . render)
106 |
107 | -- | Comma separate the renderings of a heterogeneous list.
108 | renderCommaSeparatedConstraint
109 | :: forall c xs expression. (All c xs, SListI xs)
110 | => (forall x. c x => expression x -> ByteString)
111 | -> NP expression xs -> ByteString
112 | renderCommaSeparatedConstraint render
113 | = commaSeparated
114 | . hcollapse
115 | . hcmap (Proxy @c) (K . render)
116 |
117 | -- | Comma separate the `Maybe` renderings of a heterogeneous list, dropping
118 | -- `Nothing`s.
119 | renderCommaSeparatedMaybe
120 | :: SListI xs
121 | => (forall x. expression x -> Maybe ByteString)
122 | -> NP expression xs -> ByteString
123 | renderCommaSeparatedMaybe render
124 | = commaSeparated
125 | . catMaybes
126 | . hcollapse
127 | . hmap (K . render)
128 |
129 | -- | Render a promoted `Nat`.
130 | renderNat :: forall n. KnownNat n => ByteString
131 | renderNat = fromString (show (natVal' (proxy# :: Proxy# n)))
132 |
133 | -- | Render a promoted `Symbol`.
134 | renderSymbol :: forall s. KnownSymbol s => ByteString
135 | renderSymbol = fromString (symbolVal' (proxy# :: Proxy# s))
136 |
137 | -- | A class for rendering SQL
138 | class RenderSQL sql where renderSQL :: sql -> ByteString
139 |
140 | -- | Print SQL.
141 | printSQL :: (RenderSQL sql, MonadIO io) => sql -> io ()
142 | printSQL = liftIO . Char8.putStrLn . renderSQL
143 |
144 | -- | `escape` a character to prevent injection
145 | escape :: Char -> String
146 | escape = \case
147 | '\NUL' -> ""
148 | '\'' -> "''"
149 | '"' -> "\\\""
150 | '\b' -> "\\b"
151 | '\n' -> "\\n"
152 | '\r' -> "\\r"
153 | '\t' -> "\\t"
154 | '\\' -> "\\\\"
155 | c -> [c]
156 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Connection.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Session.Connection
3 | Description: database connections
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | database connections
9 | -}
10 |
11 | {-# LANGUAGE
12 | DataKinds
13 | , PolyKinds
14 | , RankNTypes
15 | , TypeOperators
16 | #-}
17 |
18 | module Squeal.PostgreSQL.Session.Connection
19 | ( LibPQ.Connection
20 | , connectdb
21 | , finish
22 | , lowerConnection
23 | , SOP.K (..)
24 | , SOP.unK
25 | ) where
26 |
27 | import Control.Monad.IO.Class
28 | import Data.ByteString (ByteString)
29 |
30 | import Squeal.PostgreSQL.Type.Schema
31 |
32 | import qualified Generics.SOP as SOP
33 | import qualified Database.PostgreSQL.LibPQ as LibPQ
34 |
35 | -- $setup
36 | -- >>> import Squeal.PostgreSQL
37 |
38 | {- | Makes a new connection to the database server.
39 |
40 | This function opens a new database connection using the parameters taken
41 | from the string conninfo.
42 |
43 | The passed string can be empty to use all default parameters, or it can
44 | contain one or more parameter settings separated by whitespace.
45 | Each parameter setting is in the form keyword = value. Spaces around the equal
46 | sign are optional. To write an empty value or a value containing spaces,
47 | surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
48 | backslashes within the value must be escaped with a backslash, i.e., ' and \.
49 |
50 | To specify the schema you wish to connect with, use type application.
51 |
52 | >>> :set -XDataKinds
53 | >>> :set -XPolyKinds
54 | >>> :set -XTypeOperators
55 | >>> type DB = '["public" ::: '["tab" ::: 'Table ('[] :=> '["col" ::: 'NoDef :=> 'Null 'PGint2])]]
56 | >>> :set -XTypeApplications
57 | >>> :set -XOverloadedStrings
58 | >>> conn <- connectdb @DB "host=localhost port=5432 dbname=exampledb user=postgres password=postgres"
59 |
60 | Note that, for now, squeal doesn't offer any protection from connecting
61 | with the wrong schema!
62 | -}
63 | connectdb
64 | :: forall (db :: SchemasType) io
65 | . MonadIO io
66 | => ByteString -- ^ conninfo
67 | -> io (SOP.K LibPQ.Connection db)
68 | connectdb = fmap SOP.K . liftIO . LibPQ.connectdb
69 |
70 | -- | Closes the connection to the server.
71 | finish :: MonadIO io => SOP.K LibPQ.Connection db -> io ()
72 | finish = liftIO . LibPQ.finish . SOP.unK
73 |
74 | -- | Safely `lowerConnection` to a smaller schema.
75 | lowerConnection
76 | :: SOP.K LibPQ.Connection (schema ': db)
77 | -> SOP.K LibPQ.Connection db
78 | lowerConnection (SOP.K conn) = SOP.K conn
79 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Exception.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Session.Exception
3 | Description: exceptions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | exceptions
9 | -}
10 |
11 | {-# LANGUAGE
12 | OverloadedStrings
13 | , PatternSynonyms
14 | #-}
15 |
16 | module Squeal.PostgreSQL.Session.Exception
17 | ( SquealException (..)
18 | , pattern UniqueViolation
19 | , pattern CheckViolation
20 | , pattern SerializationFailure
21 | , pattern DeadlockDetected
22 | , SQLState (..)
23 | , LibPQ.ExecStatus (..)
24 | , catchSqueal
25 | , handleSqueal
26 | , trySqueal
27 | , throwSqueal
28 | ) where
29 |
30 | import Control.Monad.Catch
31 | import Data.ByteString (ByteString)
32 | import Data.Text (Text)
33 |
34 | import qualified Database.PostgreSQL.LibPQ as LibPQ
35 |
36 | -- $setup
37 | -- >>> import Squeal.PostgreSQL
38 |
39 | -- | the state of LibPQ
40 | data SQLState = SQLState
41 | { sqlExecStatus :: LibPQ.ExecStatus
42 | , sqlStateCode :: ByteString
43 | -- ^ https://www.postgresql.org/docs/current/static/errcodes-appendix.html
44 | , sqlErrorMessage :: ByteString
45 | } deriving (Eq, Show)
46 |
47 | -- | `Exception`s that can be thrown by Squeal.
48 | data SquealException
49 | = SQLException SQLState
50 | -- ^ SQL exception state
51 | | ConnectionException Text
52 | -- ^ `Database.PostgreSQL.LibPQ` function connection exception
53 | | DecodingException Text Text
54 | -- ^ decoding exception function and error message
55 | | ColumnsException Text LibPQ.Column
56 | -- ^ unexpected number of columns
57 | | RowsException Text LibPQ.Row LibPQ.Row
58 | -- ^ too few rows, expected at least and actual number of rows
59 | deriving (Eq, Show)
60 | instance Exception SquealException
61 |
62 | -- | A pattern for unique violation exceptions.
63 | pattern UniqueViolation :: ByteString -> SquealException
64 | pattern UniqueViolation msg =
65 | SQLException (SQLState LibPQ.FatalError "23505" msg)
66 | -- | A pattern for check constraint violation exceptions.
67 | pattern CheckViolation :: ByteString -> SquealException
68 | pattern CheckViolation msg =
69 | SQLException (SQLState LibPQ.FatalError "23514" msg)
70 | -- | A pattern for serialization failure exceptions.
71 | pattern SerializationFailure :: ByteString -> SquealException
72 | pattern SerializationFailure msg =
73 | SQLException (SQLState LibPQ.FatalError "40001" msg)
74 | -- | A pattern for deadlock detection exceptions.
75 | pattern DeadlockDetected :: ByteString -> SquealException
76 | pattern DeadlockDetected msg =
77 | SQLException (SQLState LibPQ.FatalError "40P01" msg)
78 |
79 | -- | Catch `SquealException`s.
80 | catchSqueal
81 | :: MonadCatch m
82 | => m a
83 | -> (SquealException -> m a) -- ^ handler
84 | -> m a
85 | catchSqueal = catch
86 |
87 | -- | Handle `SquealException`s.
88 | handleSqueal
89 | :: MonadCatch m
90 | => (SquealException -> m a) -- ^ handler
91 | -> m a -> m a
92 | handleSqueal = handle
93 |
94 | -- | `Either` return a `SquealException` or a result.
95 | trySqueal :: MonadCatch m => m a -> m (Either SquealException a)
96 | trySqueal = try
97 |
98 | -- | Throw `SquealException`s.
99 | throwSqueal :: MonadThrow m => SquealException -> m a
100 | throwSqueal = throwM
101 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Indexed.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Session.Indexed
3 | Description: indexed session monad
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | `Squeal.PostgreSQL.Indexed` provides an indexed monad transformer
9 | class and a class extending it to run `Definition`s.
10 | -}
11 |
12 | {-# LANGUAGE
13 | DataKinds
14 | , DefaultSignatures
15 | , FlexibleContexts
16 | , FlexibleInstances
17 | , FunctionalDependencies
18 | , PolyKinds
19 | , MultiParamTypeClasses
20 | , QuantifiedConstraints
21 | , RankNTypes
22 | , TypeApplications
23 | , TypeFamilies
24 | , UndecidableInstances
25 | #-}
26 |
27 | module Squeal.PostgreSQL.Session.Indexed
28 | ( IndexedMonadTrans (..)
29 | , Indexed (..)
30 | , IndexedMonadTransPQ (..)
31 | , indexedDefine
32 | ) where
33 |
34 | import Control.Category (Category (..))
35 | import Control.Monad
36 | import Control.Monad.IO.Class
37 | import Control.Monad.Trans
38 | import Data.Function ((&))
39 | import Prelude hiding (id, (.))
40 |
41 | import Squeal.PostgreSQL.Definition
42 |
43 | {- | An [Atkey indexed monad]
44 | (https://bentnib.org/paramnotions-jfp.pdf)
45 | is a `Functor` [enriched category]
46 | (https://ncatlab.org/nlab/show/enriched+category).
47 | An indexed monad transformer transforms a `Monad` into an indexed monad,
48 | and is a monad transformer when its source and target are the same,
49 | enabling use of standard @do@ notation for endo-index operations.
50 | -}
51 | class
52 | ( forall i j m. Monad m => Functor (t i j m)
53 | , forall i m. Monad m => Monad (t i i m)
54 | , forall i. MonadTrans (t i i)
55 | ) => IndexedMonadTrans t where
56 |
57 | {-# MINIMAL pqJoin | pqBind #-}
58 |
59 | -- | indexed analog of `<*>`
60 | pqAp
61 | :: Monad m
62 | => t i j m (x -> y)
63 | -> t j k m x
64 | -> t i k m y
65 | pqAp tf tx = pqBind (<$> tx) tf
66 |
67 | -- | indexed analog of `join`
68 | pqJoin
69 | :: Monad m
70 | => t i j m (t j k m y)
71 | -> t i k m y
72 | pqJoin t = t & pqBind id
73 |
74 | -- | indexed analog of `=<<`
75 | pqBind
76 | :: Monad m
77 | => (x -> t j k m y)
78 | -> t i j m x
79 | -> t i k m y
80 | pqBind f t = pqJoin (f <$> t)
81 |
82 | -- | indexed analog of flipped `>>`
83 | pqThen
84 | :: Monad m
85 | => t j k m y
86 | -> t i j m x
87 | -> t i k m y
88 | pqThen pq2 pq1 = pq1 & pqBind (\ _ -> pq2)
89 |
90 | -- | indexed analog of `<=<`
91 | pqAndThen
92 | :: Monad m
93 | => (y -> t j k m z)
94 | -> (x -> t i j m y)
95 | -> x -> t i k m z
96 | pqAndThen g f x = pqBind g (f x)
97 |
98 | {- | `Indexed` reshuffles the type parameters of an `IndexedMonadTrans`,
99 | exposing its `Category` instance.-}
100 | newtype Indexed t m r i j = Indexed {runIndexed :: t i j m r}
101 | instance
102 | ( IndexedMonadTrans t
103 | , Monad m
104 | , Monoid r
105 | ) => Category (Indexed t m r) where
106 | id = Indexed (pure mempty)
107 | Indexed g . Indexed f = Indexed $ pqAp (fmap (<>) f) g
108 |
109 | {- | `IndexedMonadTransPQ` is a class for indexed monad transformers
110 | that support running `Definition`s using `define` which acts functorially in effect.
111 |
112 | * @define id = return ()@
113 | * @define (statement1 >>> statement2) = define statement1 & pqThen (define statement2)@
114 | -}
115 | class IndexedMonadTrans pq => IndexedMonadTransPQ pq where
116 | define :: MonadIO io => Definition db0 db1 -> pq db0 db1 io ()
117 |
118 | {- | Run a pure SQL `Definition` functorially in effect
119 |
120 | * @indexedDefine id = id@
121 | * @indexedDefine (def1 >>> def2) = indexedDefine def1 >>> indexedDefine def2@
122 | -}
123 | indexedDefine
124 | :: (IndexedMonadTransPQ pq, MonadIO io)
125 | => Definition db0 db1 -> Indexed pq io () db0 db1
126 | indexedDefine = Indexed . define
127 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Pool.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Pool
3 | Description: connection pools
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | Connection pools.
9 |
10 | Typical use case would be to create your pool using `createConnectionPool`
11 | and run anything that requires the pool connection with `usingConnectionPool`.
12 |
13 | Here's a simplified example:
14 |
15 | >>> import Squeal.PostgreSQL
16 |
17 | >>> :{
18 | do
19 | let
20 | qry :: Query_ (Public '[]) () (Only Char)
21 | qry = values_ (inline 'a' `as` #fromOnly)
22 | pool <- createConnectionPool "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" 1 0.5 10
23 | chr <- usingConnectionPool pool $ do
24 | result <- runQuery qry
25 | Just (Only a) <- firstRow result
26 | return a
27 | destroyConnectionPool pool
28 | putChar chr
29 | :}
30 | a
31 | -}
32 |
33 | {-# LANGUAGE
34 | CPP
35 | , DeriveFunctor
36 | , FlexibleContexts
37 | , FlexibleInstances
38 | , InstanceSigs
39 | , MultiParamTypeClasses
40 | , PolyKinds
41 | , RankNTypes
42 | , ScopedTypeVariables
43 | , TypeFamilies
44 | , DataKinds
45 | , PolyKinds
46 | , UndecidableInstances
47 | #-}
48 |
49 | module Squeal.PostgreSQL.Session.Pool
50 | ( -- * Pool
51 | Pool
52 | , createConnectionPool
53 | , usingConnectionPool
54 | , destroyConnectionPool
55 | ) where
56 |
57 | import Control.Monad.Catch
58 | import Control.Monad.IO.Class
59 | import Data.ByteString
60 | import Data.Time
61 | import Data.Pool
62 |
63 | import Squeal.PostgreSQL.Type.Schema
64 | import Squeal.PostgreSQL.Session (PQ (..))
65 | import Squeal.PostgreSQL.Session.Connection
66 |
67 | -- | Create a striped pool of connections.
68 | -- Although the garbage collector will destroy all idle connections when the pool is garbage collected it's recommended to manually `destroyConnectionPool` when you're done with the pool so that the connections are freed up as soon as possible.
69 | createConnectionPool
70 | :: forall (db :: SchemasType) io. MonadIO io
71 | => ByteString
72 | -- ^ The passed string can be empty to use all default parameters, or it can
73 | -- contain one or more parameter settings separated by whitespace.
74 | -- Each parameter setting is in the form keyword = value. Spaces around the equal
75 | -- sign are optional. To write an empty value or a value containing spaces,
76 | -- surround it with single quotes, e.g., keyword = 'a value'. Single quotes and
77 | -- backslashes within the value must be escaped with a backslash, i.e., ' and \.
78 | -> Int
79 | -- ^ The number of stripes (distinct sub-pools) to maintain. The smallest acceptable value is 1.
80 | -> NominalDiffTime
81 | -- ^ Amount of time for which an unused connection is kept open. The smallest acceptable value is 0.5 seconds.
82 | -- The elapsed time before destroying a connection may be a little longer than requested, as the reaper thread wakes at 1-second intervals.
83 | -> Int
84 | -- ^ Maximum number of connections to keep open per stripe. The smallest acceptable value is 1.
85 | -- Requests for connections will block if this limit is reached on a single stripe, even if other stripes have idle connections available.
86 | -> io (Pool (K Connection db))
87 | createConnectionPool conninfo stripes idle maxResrc =
88 | #if MIN_VERSION_resource_pool(0,4,0)
89 | liftIO . newPool $ setNumStripes
90 | (Just stripes)
91 | (defaultPoolConfig (connectdb conninfo) finish (realToFrac idle) maxResrc)
92 | #else
93 | liftIO $ createPool (connectdb conninfo) finish stripes idle maxResrc
94 | #endif
95 |
96 | {-|
97 | Temporarily take a connection from a `Pool`, perform an action with it,
98 | and return it to the pool afterwards.
99 |
100 | If the pool has an idle connection available, it is used immediately.
101 | Otherwise, if the maximum number of connections has not yet been reached,
102 | a new connection is created and used.
103 | If the maximum number of connections has been reached, this function blocks
104 | until a connection becomes available.
105 | -}
106 | usingConnectionPool
107 | :: (MonadIO io, MonadMask io)
108 | => Pool (K Connection db) -- ^ pool
109 | -> PQ db db io x -- ^ session
110 | -> io x
111 | usingConnectionPool pool (PQ session) = mask $ \restore -> do
112 | (conn, local) <- liftIO $ takeResource pool
113 | ret <- restore (session conn) `onException`
114 | liftIO (destroyResource pool local conn)
115 | liftIO $ putResource local conn
116 | return $ unK ret
117 |
118 | {- |
119 | Destroy all connections in all stripes in the pool.
120 | Note that this will ignore any exceptions in the destroy function.
121 |
122 | This function is useful when you detect that all connections
123 | in the pool are broken. For example after a database has been
124 | restarted all connections opened before the restart will be broken.
125 | In that case it's better to close those connections so that
126 | `usingConnectionPool` won't take a broken connection from the pool
127 | but will open a new connection instead.
128 |
129 | Another use-case for this function is that when you know you are done
130 | with the pool you can destroy all idle connections immediately
131 | instead of waiting on the garbage collector to destroy them,
132 | thus freeing up those connections sooner.
133 | -}
134 | destroyConnectionPool
135 | :: MonadIO io
136 | => Pool (K Connection db) -- ^ pool
137 | -> io ()
138 | destroyConnectionPool = liftIO . destroyAllResources
139 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Result.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Session.Result
3 | Description: results
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | Get values from a `Result`.
9 | -}
10 |
11 | {-# LANGUAGE
12 | FlexibleContexts
13 | , FlexibleInstances
14 | , GADTs
15 | , LambdaCase
16 | , OverloadedStrings
17 | , ScopedTypeVariables
18 | , TypeApplications
19 | , UndecidableInstances
20 | #-}
21 |
22 | module Squeal.PostgreSQL.Session.Result
23 | ( Result (..)
24 | , MonadResult (..)
25 | , liftResult
26 | , nextRow
27 | ) where
28 |
29 | import Control.Exception (throw)
30 | import Control.Monad (when, (<=<))
31 | import Control.Monad.Catch
32 | import Control.Monad.IO.Class
33 | import Data.ByteString (ByteString)
34 | import Data.Text (Text)
35 | import Data.Traversable (for)
36 | import Text.Read (readMaybe)
37 |
38 | import qualified Data.ByteString as ByteString
39 | import qualified Data.ByteString.Char8 as Char8
40 | import qualified Data.Text.Encoding as Text
41 | import qualified Database.PostgreSQL.LibPQ as LibPQ
42 | import qualified Generics.SOP as SOP
43 |
44 | import Squeal.PostgreSQL.Session.Decode
45 | import Squeal.PostgreSQL.Session.Exception
46 |
47 | {- | `Result`s are generated by executing
48 | `Squeal.PostgreSQL.Session.Statement`s
49 | in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`.
50 |
51 | They contain an underlying `LibPQ.Result`
52 | and a `DecodeRow`.
53 | -}
54 | data Result y where
55 | Result
56 | :: SOP.SListI row
57 | => DecodeRow row y
58 | -> LibPQ.Result
59 | -> Result y
60 | instance Functor Result where
61 | fmap f (Result decode result) = Result (fmap f decode) result
62 |
63 | {- | A `MonadResult` operation extracts values
64 | from the `Result` of a `Squeal.PostgreSQL.Session.Monad.MonadPQ` operation.
65 | There is no need to define instances of `MonadResult`.
66 | An instance of `MonadIO` implies an instance of `MonadResult`.
67 | However, the constraint `MonadResult`
68 | does not imply the constraint `MonadIO`.
69 | -}
70 | class Monad m => MonadResult m where
71 | -- | Get a row corresponding to a given row number from a `LibPQ.Result`,
72 | -- throwing an exception if the row number is out of bounds.
73 | getRow :: LibPQ.Row -> Result y -> m y
74 | -- | Get all rows from a `LibPQ.Result`.
75 | getRows :: Result y -> m [y]
76 | -- | Get the first row if possible from a `LibPQ.Result`.
77 | firstRow :: Result y -> m (Maybe y)
78 | -- | Returns the number of rows (tuples) in the query result.
79 | ntuples :: Result y -> m LibPQ.Row
80 | -- | Returns the number of columns (fields) in the query result.
81 | nfields :: Result y -> m LibPQ.Column
82 | {- |
83 | Returns the command status tag from the SQL command
84 | that generated the `Result`.
85 | Commonly this is just the name of the command,
86 | but it might include additional data such as the number of rows processed.
87 | -}
88 | cmdStatus :: Result y -> m Text
89 | {- |
90 | Returns the number of rows affected by the SQL command.
91 | This function returns `Just` the number of
92 | rows affected by the SQL statement that generated the `Result`.
93 | This function can only be used following the execution of a
94 | SELECT, CREATE TABLE AS, INSERT, UPDATE, DELETE, MOVE, FETCH,
95 | or COPY statement,or an EXECUTE of a prepared query that
96 | contains an INSERT, UPDATE, or DELETE statement.
97 | If the command that generated the PGresult was anything else,
98 | `cmdTuples` returns `Nothing`.
99 | -}
100 | cmdTuples :: Result y -> m (Maybe LibPQ.Row)
101 | -- | Returns the result status of the command.
102 | resultStatus :: Result y -> m LibPQ.ExecStatus
103 | -- | Check if a `Result`'s status is either `LibPQ.CommandOk`
104 | -- or `LibPQ.TuplesOk` otherwise `throw` a `SQLException`.
105 | okResult :: Result y -> m ()
106 | -- | Returns the error message most recently generated by an operation
107 | -- on the connection.
108 | resultErrorMessage :: Result y -> m (Maybe ByteString)
109 | -- | Returns the error code most recently generated by an operation
110 | -- on the connection.
111 | --
112 | -- https://www.postgresql.org/docs/current/static/errcodes-appendix.html
113 | resultErrorCode :: Result y -> m (Maybe ByteString)
114 |
115 | instance (Monad io, MonadIO io) => MonadResult io where
116 | getRow r (Result decode result) = liftIO $ do
117 | numRows <- LibPQ.ntuples result
118 | numCols <- LibPQ.nfields result
119 | when (numRows < r) $ throw $ RowsException "getRow" r numRows
120 | row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]
121 | case SOP.fromList row' of
122 | Nothing -> throw $ ColumnsException "getRow" numCols
123 | Just row -> case execDecodeRow decode row of
124 | Left parseError -> throw $ DecodingException "getRow" parseError
125 | Right y -> return y
126 |
127 | getRows (Result decode result) = liftIO $ do
128 | numCols <- LibPQ.nfields result
129 | numRows <- LibPQ.ntuples result
130 | for [0 .. numRows - 1] $ \ r -> do
131 | row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]
132 | case SOP.fromList row' of
133 | Nothing -> throw $ ColumnsException "getRows" numCols
134 | Just row -> case execDecodeRow decode row of
135 | Left parseError -> throw $ DecodingException "getRows" parseError
136 | Right y -> return y
137 |
138 | firstRow (Result decode result) = liftIO $ do
139 | numRows <- LibPQ.ntuples result
140 | numCols <- LibPQ.nfields result
141 | if numRows <= 0 then return Nothing else do
142 | row' <- traverse (LibPQ.getvalue result 0) [0 .. numCols - 1]
143 | case SOP.fromList row' of
144 | Nothing -> throw $ ColumnsException "firstRow" numCols
145 | Just row -> case execDecodeRow decode row of
146 | Left parseError -> throw $ DecodingException "firstRow" parseError
147 | Right y -> return $ Just y
148 |
149 | ntuples = liftResult LibPQ.ntuples
150 |
151 | nfields = liftResult LibPQ.nfields
152 |
153 | resultStatus = liftResult LibPQ.resultStatus
154 |
155 | cmdStatus = liftResult (getCmdStatus <=< LibPQ.cmdStatus)
156 | where
157 | getCmdStatus = \case
158 | Nothing -> throwM $ ConnectionException "LibPQ.cmdStatus"
159 | Just bytes -> return $ Text.decodeUtf8 bytes
160 |
161 | cmdTuples = liftResult (getCmdTuples <=< LibPQ.cmdTuples)
162 | where
163 | getCmdTuples = \case
164 | Nothing -> throwM $ ConnectionException "LibPQ.cmdTuples"
165 | Just bytes -> return $
166 | if ByteString.null bytes
167 | then Nothing
168 | else fromInteger <$> readMaybe (Char8.unpack bytes)
169 |
170 | okResult = liftResult okResult_
171 |
172 | resultErrorMessage = liftResult LibPQ.resultErrorMessage
173 |
174 | resultErrorCode = liftResult (flip LibPQ.resultErrorField LibPQ.DiagSqlstate)
175 |
176 | -- | Intended to be used for unfolding in streaming libraries, `nextRow`
177 | -- takes a total number of rows (which can be found with `ntuples`)
178 | -- and a `LibPQ.Result` and given a row number if it's too large returns `Nothing`,
179 | -- otherwise returning the row along with the next row number.
180 | nextRow
181 | :: MonadIO io
182 | => LibPQ.Row -- ^ total number of rows
183 | -> Result y -- ^ result
184 | -> LibPQ.Row -- ^ row number
185 | -> io (Maybe (LibPQ.Row, y))
186 | nextRow total (Result decode result) r
187 | = liftIO $ if r >= total then return Nothing else do
188 | numCols <- LibPQ.nfields result
189 | row' <- traverse (LibPQ.getvalue result r) [0 .. numCols - 1]
190 | case SOP.fromList row' of
191 | Nothing -> throw $ ColumnsException "nextRow" numCols
192 | Just row -> case execDecodeRow decode row of
193 | Left parseError -> throw $ DecodingException "nextRow" parseError
194 | Right y -> return $ Just (r+1, y)
195 |
196 | okResult_ :: MonadIO io => LibPQ.Result -> io ()
197 | okResult_ result = liftIO $ do
198 | status <- LibPQ.resultStatus result
199 | case status of
200 | LibPQ.CommandOk -> return ()
201 | LibPQ.TuplesOk -> return ()
202 | _ -> do
203 | stateCodeMaybe <- LibPQ.resultErrorField result LibPQ.DiagSqlstate
204 | case stateCodeMaybe of
205 | Nothing -> throw $ ConnectionException "LibPQ.resultErrorField"
206 | Just stateCode -> do
207 | msgMaybe <- LibPQ.resultErrorMessage result
208 | case msgMaybe of
209 | Nothing -> throw $ ConnectionException "LibPQ.resultErrorMessage"
210 | Just msg -> throw . SQLException $ SQLState status stateCode msg
211 |
212 | -- | Lifts actions on results from @LibPQ@.
213 | liftResult
214 | :: MonadIO io
215 | => (LibPQ.Result -> IO x)
216 | -> Result y -> io x
217 | liftResult f (Result _ result) = liftIO $ f result
218 |
219 | execDecodeRow
220 | :: DecodeRow row y
221 | -> SOP.NP (SOP.K (Maybe ByteString)) row
222 | -> Either Text y
223 | execDecodeRow decode = runDecodeRow decode
224 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Statement.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Session.Statement
3 | Description: statements
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | A top-level `Statement` type wraps a `Squeal.PostgreSQL.Query.Query`
9 | or `Squeal.PostgreSQL.Manipulation.Manipulation`
10 | together with an `EncodeParams` and a `DecodeRow`.
11 | -}
12 |
13 | {-# LANGUAGE
14 | DataKinds
15 | , DeriveFunctor
16 | , DeriveFoldable
17 | , DeriveGeneric
18 | , DeriveTraversable
19 | , FlexibleContexts
20 | , GADTs
21 | , RankNTypes
22 | #-}
23 |
24 | module Squeal.PostgreSQL.Session.Statement
25 | ( -- * Statement
26 | Statement (..)
27 | , query
28 | , manipulation
29 | -- * Prepared
30 | , Prepared (..)
31 | ) where
32 |
33 | import Control.Applicative
34 | import Control.Arrow
35 | import Control.Category
36 | import Control.Monad
37 | import Control.Monad.Fix
38 | import Data.Functor.Contravariant
39 | import Data.Profunctor
40 | import Data.Profunctor.Traversing
41 | import GHC.Generics
42 | import Prelude hiding ((.),id)
43 |
44 | import qualified Generics.SOP as SOP
45 |
46 | import Squeal.PostgreSQL.Manipulation
47 | import Squeal.PostgreSQL.Session.Decode
48 | import Squeal.PostgreSQL.Session.Encode
49 | import Squeal.PostgreSQL.Session.Oid
50 | import Squeal.PostgreSQL.Query
51 | import Squeal.PostgreSQL.Render hiding ((<+>))
52 |
53 | -- | A `Statement` consists of a `Squeal.PostgreSQL.Statement.Manipulation`
54 | -- or a `Squeal.PostgreSQL.Session.Statement.Query` that can be run
55 | -- in a `Squeal.PostgreSQL.Session.Monad.MonadPQ`.
56 | data Statement db x y where
57 | -- | Constructor for a data manipulation language `Statement`
58 | Manipulation
59 | :: (SOP.All (OidOfNull db) params, SOP.SListI row)
60 | => EncodeParams db params x -- ^ encoding of parameters
61 | -> DecodeRow row y -- ^ decoding of returned rows
62 | -> Manipulation '[] db params row
63 | -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,
64 | -- `Squeal.PostgreSQL.Manipulation.Update.update`,
65 | -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ...
66 | -> Statement db x y
67 | -- | Constructor for a structured query language `Statement`
68 | Query
69 | :: (SOP.All (OidOfNull db) params, SOP.SListI row)
70 | => EncodeParams db params x -- ^ encoding of parameters
71 | -> DecodeRow row y -- ^ decoding of returned rows
72 | -> Query '[] '[] db params row
73 | -- ^ `Squeal.PostgreSQL.Query.Select.select`,
74 | -- `Squeal.PostgreSQL.Query.Values.values`, ...
75 | -> Statement db x y
76 |
77 | instance Profunctor (Statement db) where
78 | lmap f (Manipulation encode decode q) =
79 | Manipulation (contramap f encode) decode q
80 | lmap f (Query encode decode q) =
81 | Query (contramap f encode) decode q
82 | rmap f (Manipulation encode decode q) =
83 | Manipulation encode (fmap f decode) q
84 | rmap f (Query encode decode q) =
85 | Query encode (fmap f decode) q
86 | dimap f g (Manipulation encode decode q) =
87 | Manipulation (contramap f encode) (fmap g decode) q
88 | dimap f g (Query encode decode q) =
89 | Query (contramap f encode) (fmap g decode) q
90 |
91 | instance Functor (Statement db x) where fmap = rmap
92 |
93 | instance RenderSQL (Statement db x y) where
94 | renderSQL (Manipulation _ _ q) = renderSQL q
95 | renderSQL (Query _ _ q) = renderSQL q
96 |
97 | -- | Smart constructor for a structured query language `Statement`
98 | query ::
99 | ( GenericParams db params x xs
100 | , GenericRow row y ys
101 | ) => Query '[] '[] db params row
102 | -- ^ `Squeal.PostgreSQL.Query.Select.select`,
103 | -- `Squeal.PostgreSQL.Query.Values.values`, ...
104 | -> Statement db x y
105 | query = Query genericParams genericRow
106 |
107 | -- | Smart constructor for a data manipulation language `Statement`
108 | manipulation ::
109 | ( GenericParams db params x xs
110 | , GenericRow row y ys
111 | ) => Manipulation '[] db params row
112 | -- ^ `Squeal.PostgreSQL.Manipulation.Insert.insertInto`,
113 | -- `Squeal.PostgreSQL.Manipulation.Update.update`,
114 | -- or `Squeal.PostgreSQL.Manipulation.Delete.deleteFrom`, ...
115 | -> Statement db x y
116 | manipulation = Manipulation genericParams genericRow
117 |
118 | {- |
119 | `Squeal.PostgreSQL.Session.Monad.prepare` and
120 | `Squeal.PostgreSQL.Session.Monad.prepare_` create a `Prepared` statement.
121 | A `Prepared` statement is a server-side object
122 | that can be used to optimize performance.
123 | When `Squeal.PostgreSQL.Session.Monad.prepare`
124 | or `Squeal.PostgreSQL.Session.Monad.prepare_` is executed,
125 | the specified `Statement` is parsed, analyzed, and rewritten.
126 |
127 | When the `runPrepared` command is subsequently issued,
128 | the `Prepared` statement is planned and executed.
129 | This division of labor avoids repetitive parse analysis work,
130 | while allowing the execution plan to
131 | depend on the specific parameter values supplied.
132 |
133 | `Prepared` statements only last for the duration
134 | of the current database session.
135 | `Prepared` statements can be manually cleaned up
136 | using the `deallocate` command.
137 | -}
138 | data Prepared m x y = Prepared
139 | { runPrepared :: x -> m y -- ^ execute a prepared statement
140 | , deallocate :: m () -- ^ manually clean up a prepared statement
141 | } deriving (Functor, Generic, Generic1)
142 |
143 | instance Applicative m => Applicative (Prepared m x) where
144 | pure a = Prepared (\_ -> pure a) (pure ())
145 | p1 <*> p2 = Prepared
146 | (run2 (<*>) p1 p2)
147 | (deallocate p1 *> deallocate p2)
148 |
149 | instance Alternative m => Alternative (Prepared m x) where
150 | empty = Prepared (runKleisli empty) empty
151 | p1 <|> p2 = Prepared
152 | (run2 (<|>) p1 p2)
153 | (deallocate p1 *> deallocate p2)
154 |
155 | instance Functor m => Profunctor (Prepared m) where
156 | dimap g f prepared = Prepared
157 | (fmap f . runPrepared prepared . g)
158 | (deallocate prepared)
159 |
160 | instance Monad m => Strong (Prepared m) where
161 | first' p = Prepared (run1 first' p) (deallocate p)
162 | second' p = Prepared (run1 second' p) (deallocate p)
163 |
164 | instance Monad m => Choice (Prepared m) where
165 | left' p = Prepared (run1 left' p) (deallocate p)
166 | right' p = Prepared (run1 right' p) (deallocate p)
167 |
168 | instance MonadFix m => Costrong (Prepared m) where
169 | unfirst p = Prepared (run1 unfirst p) (deallocate p)
170 | unsecond p = Prepared (run1 unsecond p) (deallocate p)
171 |
172 | instance Monad m => Category (Prepared m) where
173 | id = Prepared return (return ())
174 | cd . ab = Prepared
175 | (runPrepared ab >=> runPrepared cd)
176 | (deallocate ab >> deallocate cd)
177 |
178 | instance Monad m => Arrow (Prepared m) where
179 | arr ab = Prepared (return . ab) (return ())
180 | first = first'
181 | second = second'
182 | ab *** cd = first ab >>> second cd
183 | ab &&& ac = Prepared
184 | (run2 (&&&) ab ac)
185 | (deallocate ab >> deallocate ac)
186 |
187 | instance Monad m => ArrowChoice (Prepared m) where
188 | left = left'
189 | right = right'
190 | ab +++ cd = left ab >>> right cd
191 | bd ||| cd = Prepared
192 | (run2 (|||) bd cd)
193 | (deallocate bd >> deallocate cd)
194 |
195 | instance MonadFix m => ArrowLoop (Prepared m) where
196 | loop p = Prepared (run1 loop p) (deallocate p)
197 |
198 | instance MonadPlus m => ArrowZero (Prepared m) where
199 | zeroArrow = Prepared (runKleisli zeroArrow) (return ())
200 |
201 | instance MonadPlus m => ArrowPlus (Prepared m) where
202 | p1 <+> p2 = Prepared
203 | (run2 (<+>) p1 p2)
204 | (deallocate p1 >> deallocate p2)
205 |
206 | instance Monad m => Traversing (Prepared m) where
207 | traverse' p = Prepared (run1 traverse' p) (deallocate p)
208 |
209 | -- helper functions
210 |
211 | run1
212 | :: (Kleisli m a b -> Kleisli m c d)
213 | -> Prepared m a b -> c -> m d
214 | run1 m = runKleisli . m . Kleisli . runPrepared
215 |
216 | run2
217 | :: (Kleisli m a b -> Kleisli m c d -> Kleisli m e f)
218 | -> Prepared m a b -> Prepared m c d -> e -> m f
219 | run2 (?) p1 p2 = runKleisli $
220 | Kleisli (runPrepared p1) ? Kleisli (runPrepared p2)
221 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Session/Transaction.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Session.Transaction
3 | Description: transaction control language
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | transaction control language
9 | -}
10 |
11 | {-# LANGUAGE
12 | MonoLocalBinds
13 | , RankNTypes
14 | #-}
15 |
16 | module Squeal.PostgreSQL.Session.Transaction
17 | ( -- * Transaction
18 | Transaction
19 | , transactionally
20 | , transactionally_
21 | , transactionallyRetry
22 | , transactionallyRetry_
23 | , ephemerally
24 | , ephemerally_
25 | , withSavepoint
26 | -- * Transaction Mode
27 | , TransactionMode (..)
28 | , defaultMode
29 | , longRunningMode
30 | , retryMode
31 | , IsolationLevel (..)
32 | , AccessMode (..)
33 | , DeferrableMode (..)
34 | ) where
35 |
36 | import Control.Monad.Catch
37 | import Data.ByteString
38 |
39 | import Squeal.PostgreSQL.Session.Monad
40 | import Squeal.PostgreSQL.Session.Result
41 | import Squeal.PostgreSQL.Session.Transaction.Unsafe
42 | ( TransactionMode (..)
43 | , defaultMode
44 | , longRunningMode
45 | , retryMode
46 | , IsolationLevel (..)
47 | , AccessMode (..)
48 | , DeferrableMode (..)
49 | )
50 | import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe
51 |
52 | {- | A type of "safe" `Transaction`s,
53 | do-blocks that permit only
54 | database operations, pure functions, and synchronous exception handling
55 | forbidding arbitrary `IO` operations.
56 |
57 | To permit arbitrary `IO`,
58 |
59 | >>> import qualified Squeal.PostgreSQL.Session.Transaction.Unsafe as Unsafe
60 |
61 | Then use the @Unsafe@ qualified form of the functions below.
62 |
63 | A safe `Transaction` can be run in two ways,
64 |
65 | 1) it can be run directly in `IO` because as a
66 | universally quantified type,
67 | @Transaction db x@ permits interpretation in "subtypes" like
68 | @(MonadPQ db m, MonadIO m, MonadCatch m) => m x@
69 | or
70 | @PQ db db IO x@
71 |
72 | 2) it can be run in a transaction block, using
73 | `transactionally`, `ephemerally`,
74 | or `transactionallyRetry`
75 | -}
76 | type Transaction db x = forall m.
77 | ( MonadPQ db m
78 | , MonadResult m
79 | , MonadCatch m
80 | ) => m x
81 |
82 | {- | Run a computation `transactionally`;
83 | first `Unsafe.begin`,
84 | then run the computation,
85 | `onException` `Unsafe.rollback` and rethrow the exception,
86 | otherwise `Unsafe.commit` and `return` the result.
87 | -}
88 | transactionally
89 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx)
90 | => TransactionMode
91 | -> Transaction db x -- ^ run inside a transaction
92 | -> tx x
93 | transactionally mode tx = Unsafe.transactionally mode tx
94 |
95 | -- | Run a computation `transactionally_`, in `defaultMode`.
96 | transactionally_
97 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx)
98 | => Transaction db x -- ^ run inside a transaction
99 | -> tx x
100 | transactionally_ tx = Unsafe.transactionally_ tx
101 |
102 | {- |
103 | `transactionallyRetry` a computation;
104 |
105 | * first `Unsafe.begin`,
106 | * then `try` the computation,
107 | - if it raises a serialization failure or deadloack detection,
108 | then `Unsafe.rollback` and restart the transaction,
109 | - if it raises any other exception then `Unsafe.rollback` and rethrow the exception,
110 | - otherwise `Unsafe.commit` and `return` the result.
111 | -}
112 | transactionallyRetry
113 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx)
114 | => TransactionMode
115 | -> Transaction db x -- ^ run inside a transaction
116 | -> tx x
117 | transactionallyRetry mode tx = Unsafe.transactionallyRetry mode tx
118 |
119 | {- | `transactionallyRetry` in `retryMode`. -}
120 | transactionallyRetry_
121 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx)
122 | => Transaction db x -- ^ run inside a transaction
123 | -> tx x
124 | transactionallyRetry_ tx = Unsafe.transactionallyRetry_ tx
125 |
126 | {- | Run a computation `ephemerally`;
127 | Like `transactionally` but always `Unsafe.rollback`, useful in testing.
128 | -}
129 | ephemerally
130 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx)
131 | => TransactionMode
132 | -> Transaction db x -- ^ run inside an ephemeral transaction
133 | -> tx x
134 | ephemerally mode tx = Unsafe.ephemerally mode tx
135 |
136 | {- | Run a computation `ephemerally` in `defaultMode`. -}
137 | ephemerally_
138 | :: (MonadMask tx, MonadResult tx, MonadPQ db tx)
139 | => Transaction db x -- ^ run inside an ephemeral transaction
140 | -> tx x
141 | ephemerally_ tx = Unsafe.ephemerally_ tx
142 |
143 | {- | `withSavepoint`, used in a transaction block,
144 | allows a form of nested transactions,
145 | creating a savepoint, then running a transaction,
146 | rolling back to the savepoint if it returned `Left`,
147 | then releasing the savepoint and returning transaction's result.
148 |
149 | Make sure to run `withSavepoint` in a transaction block,
150 | not directly or you will provoke a SQL exception.
151 | -}
152 | withSavepoint
153 | :: ByteString -- ^ savepoint name
154 | -> Transaction db (Either e x)
155 | -> Transaction db (Either e x)
156 | withSavepoint sv tx = Unsafe.withSavepoint sv tx
157 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Type.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Type
3 | Description: types
4 | Copyright: (c) Eitan Chatav, 2010
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | storage newtypes
9 | -}
10 | {-# LANGUAGE
11 | AllowAmbiguousTypes
12 | , DeriveAnyClass
13 | , DeriveFoldable
14 | , DeriveFunctor
15 | , DeriveGeneric
16 | , DeriveTraversable
17 | , DerivingStrategies
18 | , DefaultSignatures
19 | , FlexibleContexts
20 | , FlexibleInstances
21 | , FunctionalDependencies
22 | , GADTs
23 | , LambdaCase
24 | , MultiParamTypeClasses
25 | , OverloadedStrings
26 | , ScopedTypeVariables
27 | , TypeApplications
28 | , TypeFamilies
29 | , DataKinds
30 | , PolyKinds
31 | , TypeOperators
32 | , UndecidableInstances
33 | , UndecidableSuperClasses
34 | #-}
35 |
36 | module Squeal.PostgreSQL.Type
37 | ( -- * Storage newtypes
38 | Money (..)
39 | , Json (..)
40 | , Jsonb (..)
41 | , Composite (..)
42 | , Enumerated (..)
43 | , VarArray (..)
44 | , FixArray (..)
45 | , VarChar, varChar, getVarChar
46 | , FixChar, fixChar, getFixChar
47 | , Only (..)
48 | ) where
49 |
50 | import Data.Proxy
51 | import Data.Int (Int64)
52 | import GHC.TypeLits
53 |
54 | import qualified Data.Text as Strict (Text)
55 | import qualified Data.Text as Strict.Text
56 | import qualified GHC.Generics as GHC
57 | import qualified Generics.SOP as SOP
58 |
59 | -- $setup
60 | -- >>> import Squeal.PostgreSQL
61 |
62 | {- | The `Money` newtype stores a monetary value in terms
63 | of the number of cents, i.e. @$2,000.20@ would be expressed as
64 | @Money { cents = 200020 }@.
65 |
66 | >>> :kind! PG Money
67 | PG Money :: PGType
68 | = 'PGmoney
69 | -}
70 | newtype Money = Money { cents :: Int64 }
71 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
72 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
73 |
74 | {- | The `Json` newtype is an indication that the Haskell
75 | type it's applied to should be stored as a
76 | `Squeal.PostgreSQL.Type.Schema.PGjson`.
77 |
78 | >>> :kind! PG (Json [String])
79 | PG (Json [String]) :: PGType
80 | = 'PGjson
81 | -}
82 | newtype Json hask = Json {getJson :: hask}
83 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
84 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
85 |
86 | {- | The `Jsonb` newtype is an indication that the Haskell
87 | type it's applied to should be stored as a
88 | `Squeal.PostgreSQL.Type.Schema.PGjsonb`.
89 |
90 | >>> :kind! PG (Jsonb [String])
91 | PG (Jsonb [String]) :: PGType
92 | = 'PGjsonb
93 | -}
94 | newtype Jsonb hask = Jsonb {getJsonb :: hask}
95 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
96 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
97 |
98 | {- | The `Composite` newtype is an indication that the Haskell
99 | type it's applied to should be stored as a
100 | `Squeal.PostgreSQL.Type.Schema.PGcomposite`.
101 |
102 | >>> :{
103 | data Complex = Complex
104 | { real :: Double
105 | , imaginary :: Double
106 | } deriving stock GHC.Generic
107 | deriving anyclass (SOP.Generic, SOP.HasDatatypeInfo)
108 | :}
109 |
110 | >>> :kind! PG (Composite Complex)
111 | PG (Composite Complex) :: PGType
112 | = 'PGcomposite
113 | '["real" ::: 'NotNull 'PGfloat8,
114 | "imaginary" ::: 'NotNull 'PGfloat8]
115 | -}
116 | newtype Composite record = Composite {getComposite :: record}
117 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
118 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
119 |
120 | {- | The `Enumerated` newtype is an indication that the Haskell
121 | type it's applied to should be stored as a
122 | `Squeal.PostgreSQL.Type.Schema.PGenum`.
123 |
124 | >>> :kind! PG (Enumerated Ordering)
125 | PG (Enumerated Ordering) :: PGType
126 | = 'PGenum '["LT", "EQ", "GT"]
127 | -}
128 | newtype Enumerated enum = Enumerated {getEnumerated :: enum}
129 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
130 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
131 |
132 | {- | The `VarArray` newtype is an indication that the Haskell
133 | type it's applied to should be stored as a
134 | `Squeal.PostgreSQL.Type.Schema.PGvararray`.
135 |
136 | >>> import Data.Vector
137 | >>> :kind! PG (VarArray (Vector Double))
138 | PG (VarArray (Vector Double)) :: PGType
139 | = 'PGvararray ('NotNull 'PGfloat8)
140 | -}
141 | newtype VarArray arr
142 | = VarArray {getVarArray :: arr}
143 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
144 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
145 |
146 | {- | The `FixArray` newtype is an indication that the Haskell
147 | type it's applied to should be stored as a
148 | `Squeal.PostgreSQL.Type.Schema.PGfixarray`.
149 |
150 | >>> :kind! PG (FixArray ((Double, Double), (Double, Double)))
151 | PG (FixArray ((Double, Double), (Double, Double))) :: PGType
152 | = 'PGfixarray '[2, 2] ('NotNull 'PGfloat8)
153 | -}
154 | newtype FixArray arr = FixArray {getFixArray :: arr}
155 | deriving stock (Eq, Ord, Show, Read, GHC.Generic)
156 | deriving anyclass (SOP.HasDatatypeInfo, SOP.Generic)
157 |
158 | -- | `Only` is a 1-tuple type, useful for encoding or decoding a singleton
159 | newtype Only x = Only { fromOnly :: x }
160 | deriving (Functor,Foldable,Traversable,Eq,Ord,Read,Show,GHC.Generic)
161 | instance SOP.Generic (Only x)
162 | instance SOP.HasDatatypeInfo (Only x)
163 |
164 | {- | Variable-length text type with limit
165 |
166 | >>> :kind! PG (VarChar 4)
167 | PG (VarChar 4) :: PGType
168 | = 'PGvarchar 4
169 | -}
170 | newtype VarChar (n :: Nat) = VarChar Strict.Text
171 | deriving (Eq,Ord,Read,Show)
172 |
173 | -- | Constructor for `VarChar`
174 | varChar :: forall n . KnownNat n => Strict.Text -> Maybe (VarChar n)
175 | varChar t =
176 | if Strict.Text.length t <= fromIntegral (natVal @n Proxy)
177 | then Just $ VarChar t
178 | else Nothing
179 |
180 | -- | Access the `Strict.Text` of a `VarChar`
181 | getVarChar :: VarChar n -> Strict.Text
182 | getVarChar (VarChar t) = t
183 |
184 | {- | Fixed-length, blank padded
185 |
186 | >>> :kind! PG (FixChar 4)
187 | PG (FixChar 4) :: PGType
188 | = 'PGchar 4
189 | -}
190 | newtype FixChar (n :: Nat) = FixChar Strict.Text
191 | deriving (Eq,Ord,Read,Show)
192 |
193 | -- | Constructor for `FixChar`
194 | fixChar :: forall n . KnownNat n => Strict.Text -> Maybe (FixChar n)
195 | fixChar t =
196 | if Strict.Text.length t == fromIntegral (natVal @n Proxy)
197 | then Just $ FixChar t
198 | else Nothing
199 |
200 | -- | Access the `Strict.Text` of a `FixChar`
201 | getFixChar :: FixChar n -> Strict.Text
202 | getFixChar (FixChar t) = t
203 |
--------------------------------------------------------------------------------
/squeal-postgresql/src/Squeal/PostgreSQL/Type/List.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Module: Squeal.PostgreSQL.Type.List
3 | Description: list related types and functions
4 | Copyright: (c) Eitan Chatav, 2019
5 | Maintainer: eitan@morphism.tech
6 | Stability: experimental
7 |
8 | Haskell singly-linked lists are very powerful. This module
9 | provides functionality for type-level lists, heterogeneous
10 | lists and type aligned lists.
11 | -}
12 |
13 | {-# LANGUAGE
14 | DataKinds
15 | , FlexibleContexts
16 | , GADTs
17 | , LambdaCase
18 | , MultiParamTypeClasses
19 | , OverloadedStrings
20 | , PolyKinds
21 | , QuantifiedConstraints
22 | , RankNTypes
23 | , ScopedTypeVariables
24 | , TypeApplications
25 | , TypeFamilies
26 | , TypeOperators
27 | , UndecidableInstances
28 | #-}
29 |
30 | module Squeal.PostgreSQL.Type.List
31 | ( -- * Heterogeneous List
32 | SOP.NP (..)
33 | , (*:)
34 | , one
35 | -- * Path
36 | , Path (..)
37 | -- * Type Level List
38 | , Join
39 | , disjoin
40 | , Additional (..)
41 | , Elem
42 | , In
43 | , Length
44 | , SubList
45 | , SubsetList
46 | -- * Type Level Sort
47 | , Sort
48 | , MergeSort
49 | , Twos
50 | , FoldMerge
51 | , Merge
52 | , MergeHelper
53 | , MapFst
54 | ) where
55 |
56 | import Control.Category.Free
57 | import Data.Function ((&))
58 | import Data.Kind
59 | import Data.Type.Bool
60 | import GHC.TypeLits
61 |
62 | import Generics.SOP as SOP
63 |
64 | -- | `Join` is simply promoted `++` and is used in @JOIN@s in
65 | -- `Squeal.PostgreSQL.Query.FromClause`s.
66 | type family Join xs ys where
67 | Join '[] ys = ys
68 | Join (x ': xs) ys = x ': Join xs ys
69 |
70 | -- | `disjoin` is a utility function for splitting an `NP` list into pieces.
71 | disjoin
72 | :: forall xs ys expr. SListI xs
73 | => NP expr (Join xs ys)
74 | -> (NP expr xs, NP expr ys)
75 | disjoin = case sList @xs of
76 | SNil -> \ys -> (Nil, ys)
77 | SCons -> \(x :* xsys) ->
78 | case disjoin xsys of (xs,ys) -> (x :* xs, ys)
79 |
80 | -- | The `Additional` class is for appending
81 | -- type-level list parameterized constructors such as `NP`,
82 | -- `Squeal.PostgreSQL.Query.Selection`, and `Squeal.PostgreSQL.Query.FromClause`.
83 | class Additional expr where
84 | also :: expr ys -> expr xs -> expr (Join xs ys)
85 | instance Additional (NP expr) where
86 | also ys = \case
87 | Nil -> ys
88 | x :* xs -> x :* (xs & also ys)
89 |
90 | -- | A useful operator for ending an `NP` list of length
91 | -- at least 2 without `Nil`
92 | (*:) :: f x -> f y -> NP f '[x,y]
93 | x *: y = x :* y :* Nil
94 | infixl 8 *:
95 |
96 | -- | A list of length `one`.
97 | one :: f x -> NP f '[x]
98 | one f = f :* Nil
99 |
100 | -- | @Elem@ is a promoted `Data.List.elem`.
101 | type family Elem x xs where
102 | Elem x '[] = 'False
103 | Elem x (x ': _) = 'True
104 | Elem x (_ ': xs) = Elem x xs
105 |
106 | -- | @In x xs@ is a constraint that proves that @x@ is in @xs@.
107 | type family In x xs :: Constraint where
108 | In x xs = If (Elem x xs) (() :: Constraint)
109 | (TypeError ('ShowType x ':<>: 'Text " is not in " ':<>: 'ShowType xs))
110 |
111 | {- | Calculate the `Length` of a type level list
112 |
113 | >>> :kind! Length '[Char,String,Bool,Double]
114 | Length '[Char,String,Bool,Double] :: Nat
115 | = 4
116 | -}
117 | type family Length (xs :: [k]) :: Nat where
118 | Length '[] = 0
119 | Length (_ : xs) = 1 + Length xs
120 |
121 | {- | `SubList` checks that one type level list is a sublist of another,
122 | with the same ordering.
123 |
124 | >>> :kind! SubList '[1,2,3] '[4,5,6]
125 | SubList '[1,2,3] '[4,5,6] :: Bool
126 | = 'False
127 | >>> :kind! SubList '[1,2,3] '[1,2,3,4]
128 | SubList '[1,2,3] '[1,2,3,4] :: Bool
129 | = 'True
130 | >>> :kind! SubList '[1,2,3] '[0,1,0,2,0,3]
131 | SubList '[1,2,3] '[0,1,0,2,0,3] :: Bool
132 | = 'True
133 | >>> :kind! SubList '[1,2,3] '[3,2,1]
134 | SubList '[1,2,3] '[3,2,1] :: Bool
135 | = 'False
136 | -}
137 | type family SubList (xs :: [k]) (ys :: [k]) :: Bool where
138 | SubList '[] ys = 'True
139 | SubList (x ': xs) '[] = 'False
140 | SubList (x ': xs) (x ': ys) = SubList xs ys
141 | SubList (x ': xs) (y ': ys) = SubList (x ': xs) ys
142 |
143 | {- | `SubsetList` checks that one type level list is a subset of another,
144 | regardless of ordering and repeats.
145 |
146 | >>> :kind! SubsetList '[1,2,3] '[4,5,6]
147 | SubsetList '[1,2,3] '[4,5,6] :: Bool
148 | = 'False
149 | >>> :kind! SubsetList '[1,2,3] '[1,2,3,4]
150 | SubsetList '[1,2,3] '[1,2,3,4] :: Bool
151 | = 'True
152 | >>> :kind! SubsetList '[1,2,3] '[0,1,0,2,0,3]
153 | SubsetList '[1,2,3] '[0,1,0,2,0,3] :: Bool
154 | = 'True
155 | >>> :kind! SubsetList '[1,2,3] '[3,2,1]
156 | SubsetList '[1,2,3] '[3,2,1] :: Bool
157 | = 'True
158 | >>> :kind! SubsetList '[1,1,1] '[3,2,1]
159 | SubsetList '[1,1,1] '[3,2,1] :: Bool
160 | = 'True
161 | -}
162 | type family SubsetList (xs :: [k]) (ys :: [k]) :: Bool where
163 | SubsetList '[] ys = 'True
164 | SubsetList (x ': xs) ys = Elem x ys && SubsetList xs ys
165 |
166 | -- | 'Sort' sorts a type level list of 'Symbol's in ascending lexicographic order
167 | type Sort ls = MergeSort (Twos ls)
168 |
169 | -- | 'MergeSort' is the workhorse behind 'Sort'
170 | type family MergeSort (ls :: [[Symbol]]) :: [Symbol] where
171 | MergeSort '[] = '[]
172 | MergeSort '[x] = x
173 | MergeSort ls = MergeSort (FoldMerge ls)
174 |
175 | -- | @Two@s splits a type-level list into a list of sorted lists of length 2 (with a singelton list potentially at the end)
176 | -- It is required for implementing 'MergeSort'
177 | type family Twos (ls :: [k]) :: [[k]] where
178 | Twos (x ': y ': rs) = Merge '[x] '[y] ': Twos rs
179 | Twos '[x] = '[ '[x]]
180 | Twos '[] = '[]
181 |
182 | -- | 'Merge' two sorted lists into one list
183 | type family Merge (ls :: [Symbol]) (rs :: [Symbol]) :: [Symbol] where
184 | Merge '[] r = r
185 | Merge l '[] = l
186 | Merge (l ': ls) (r ': rs) = MergeHelper (l ': ls) (r ': rs) (CmpSymbol l r)
187 |
188 | -- | 'MergeHelper' decides whether to take an element from the right or left list next,
189 | -- depending on the result of their comparison
190 | type family MergeHelper (ls :: [Symbol]) (rs :: [Symbol]) (cmp :: Ordering) where
191 | MergeHelper ls (r ': rs) 'GT = r ': Merge ls rs
192 | MergeHelper (l ': ls) rs leq = l ': Merge ls rs
193 |
194 | -- | 'FoldMerge' folds over a list of sorted lists, merging them into a single sorted list
195 | type family FoldMerge (ls :: [[Symbol]]) :: [[Symbol]] where
196 | FoldMerge (x ': y ': rs) = (Merge x y ': FoldMerge rs)
197 | FoldMerge '[x] = '[x]
198 | FoldMerge '[] = '[]
199 |
200 | -- | 'MapFst' takes the first value of each tuple of a type level list of tuples. Useful for getting
201 | -- only the names in associatve lists
202 | type family MapFst (ls :: [(j, k)]) :: [j] where
203 | MapFst ('(j, _) ': rest) = j ': MapFst rest
204 | MapFst '[] = '[]
205 |
--------------------------------------------------------------------------------
/squeal-postgresql/test/Doc.hs:
--------------------------------------------------------------------------------
1 | module Main (main) where
2 |
3 | import Test.DocTest
4 |
5 | main :: IO ()
6 | main = doctest [ "-isrc", "src" ]
7 |
--------------------------------------------------------------------------------
/squeal-presentation.pdf:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal-presentation.pdf
--------------------------------------------------------------------------------
/squeal.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/morphismtech/squeal/533cab7bbc4ccd8da2872af511c79acf9896cd8c/squeal.gif
--------------------------------------------------------------------------------
/stack-ghc8_10.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-18.28
2 | packages:
3 | - squeal-postgresql
4 | - squeal-postgresql-ltree
5 | - squeal-postgresql-uuid-ossp
6 |
--------------------------------------------------------------------------------
/stack-ghc8_8.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-16.31
2 | packages:
3 | - squeal-postgresql
4 | - squeal-postgresql-ltree
5 | - squeal-postgresql-uuid-ossp
6 |
--------------------------------------------------------------------------------
/stack-ghc9_0.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-19.33
2 | packages:
3 | - squeal-postgresql
4 | - squeal-postgresql-ltree
5 | - squeal-postgresql-uuid-ossp
6 |
--------------------------------------------------------------------------------
/stack-ghc9_2.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-20.26
2 | packages:
3 | - squeal-postgresql
4 | - squeal-postgresql-ltree
5 | - squeal-postgresql-uuid-ossp
6 | extra-deps:
7 | - records-sop-0.1.1.1
8 |
--------------------------------------------------------------------------------
/stack-ghc9_4.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-21.9
2 | packages:
3 | - squeal-postgresql
4 | - squeal-postgresql-ltree
5 | - squeal-postgresql-uuid-ossp
6 | extra-deps:
7 | - records-sop-0.1.1.1
8 |
--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-22.13
2 | packages:
3 | - squeal-postgresql
4 | - squeal-postgresql-ltree
5 | - squeal-postgresql-uuid-ossp
6 |
--------------------------------------------------------------------------------