Compare commits

...

14 Commits

Author SHA1 Message Date
parsonsmatt
14716a5191 sigh 2020-10-29 16:13:56 -06:00
parsonsmatt
9ad56e7de2 cabbal 2020-10-29 16:05:38 -06:00
parsonsmatt
99f9231e49 faster build perhaps 2020-10-29 16:00:39 -06:00
Matt Parsons
51c546aed3
Merge branch 'master' into format-config 2020-10-29 15:39:01 -06:00
parsonsmatt
b59cf8cd7a Merge branch 'master' into format-config 2020-10-29 15:11:45 -06:00
parsonsmatt
8c19140545 Add style guide [ci skip] 2020-10-29 07:48:53 -06:00
parsonsmatt
34ae916bf6 warnings, more tidying up 2020-10-29 07:43:05 -06:00
parsonsmatt
17b0da892f fix 2020-10-29 07:27:10 -06:00
parsonsmatt
31f7b7f6c3 fix parse error 2020-10-29 07:23:16 -06:00
parsonsmatt
ea032a9fc5 major formatting stuff 2020-10-28 23:04:02 -06:00
parsonsmatt
58575433ff Merge branch 'master' into format-config 2020-10-28 21:37:57 -06:00
parsonsmatt
d7a47ae8f9 lol 2020-10-28 13:52:07 -06:00
parsonsmatt
e92f4e0fb0 update travis 2020-10-28 13:48:36 -06:00
parsonsmatt
b5de5d81c7 Add stylish-haskell.yaml, update spacing to 4 in configs 2020-10-28 13:18:23 -06:00
19 changed files with 3060 additions and 2809 deletions

View File

@ -11,8 +11,8 @@ insert_final_newline = true
[*.{hs,md,php}] [*.{hs,md,php}]
indent_style = space indent_style = space
indent_size = 2 indent_size = 4
tab_width = 2 tab_width = 4
end_of_line = lf end_of_line = lf
charset = utf-8 charset = utf-8
trim_trailing_whitespace = true trim_trailing_whitespace = true

View File

@ -1,13 +1,14 @@
Before submitting your PR, check that you've: Before submitting your PR, check that you've:
- [ ] Bumped the version number - [ ] Bumped the version number.
- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html) - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html).
- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock - [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock.
- [ ] Ran `stylish-haskell` and otherwise adhered to the [style guide](https://github.com/bitemyapp/esqueleto/blob/master/style-guide.yaml).
After submitting your PR: After submitting your PR:
- [ ] Update the Changelog.md file with a link to your PR - [ ] Update the Changelog.md file with a link to your PR.
- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts) - [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts).
<!---Thanks so much for contributing! :) <!---Thanks so much for contributing! :)

View File

@ -35,7 +35,7 @@ jobs:
cabal: ["3.2"] cabal: ["3.2"]
ghc: ["8.6.5", "8.8.3", "8.10.1"] ghc: ["8.6.5", "8.8.3", "8.10.1"]
env: env:
CONFIG: "--enable-tests --enable-benchmarks" CONFIG: "--enable-tests --enable-benchmarks "
steps: steps:
- uses: actions/checkout@v2 - uses: actions/checkout@v2
- uses: actions/setup-haskell@v1.1.2 - uses: actions/setup-haskell@v1.1.2
@ -69,7 +69,7 @@ jobs:
key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
restore-keys: | restore-keys: |
${{ runner.os }}-${{ matrix.ghc }}- ${{ runner.os }}-${{ matrix.ghc }}-
- run: cabal v2-build $CONFIG - run: cabal v2-build --disable-optimization -j $CONFIG
- run: cabal v2-test $CONFIG - run: cabal v2-test --disable-optimization -j $CONFIG
- run: cabal v2-haddock $CONFIG - run: cabal v2-haddock -j $CONFIG
- run: cabal v2-sdist - run: cabal v2-sdist

39
.stylish-haskell.yaml Normal file
View File

@ -0,0 +1,39 @@
steps:
- imports:
align: none
list_align: with_module_name
pad_module_names: false
long_list_align: new_line_multiline
empty_list_align: inherit
list_padding: 7 # length "import "
separate_lists: false
space_surround: false
- language_pragmas:
style: vertical
align: false
remove_redundant: true
- simple_align:
cases: false
top_level_patterns: false
records: false
- trailing_whitespace: {}
indent: 4
columns: 80
newline: native
language_extensions:
- BlockArguments
- DataKinds
- DeriveGeneric
- DerivingStrategies
- DerivingVia
- ExplicitForAll
- FlexibleContexts
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedStrings
- QuantifiedConstraints
- RecordWildCards
- ScopedTypeVariables
- TemplateHaskell
- TypeApplications
- ViewPatterns

View File

@ -1,7 +1,5 @@
language: c language: c
sudo: false
services: services:
- mysql - mysql
@ -25,8 +23,9 @@ env:
- GHCVER=nightly - GHCVER=nightly
jobs: jobs:
fast_finish: true
allow_failures: allow_failures:
- GHCVER=nightly - env: GHCVER=nightly
install: install:
- export STACK_YAML=stack-$GHCVER.yaml - export STACK_YAML=stack-$GHCVER.yaml

View File

@ -23,152 +23,160 @@ extra-source-files:
changelog.md changelog.md
source-repository head source-repository head
type: git type: git
location: git://github.com/bitemyapp/esqueleto.git location: git://github.com/bitemyapp/esqueleto.git
library library
exposed-modules: exposed-modules:
Database.Esqueleto Database.Esqueleto
Database.Esqueleto.Experimental Database.Esqueleto.Experimental
Database.Esqueleto.Internal.Language Database.Esqueleto.Internal.Language
Database.Esqueleto.Internal.Sql Database.Esqueleto.Internal.Sql
Database.Esqueleto.Internal.Internal Database.Esqueleto.Internal.Internal
Database.Esqueleto.Internal.ExprParser Database.Esqueleto.Internal.ExprParser
Database.Esqueleto.MySQL Database.Esqueleto.MySQL
Database.Esqueleto.PostgreSQL Database.Esqueleto.PostgreSQL
Database.Esqueleto.PostgreSQL.JSON Database.Esqueleto.PostgreSQL.JSON
Database.Esqueleto.SQLite Database.Esqueleto.SQLite
other-modules: other-modules:
Database.Esqueleto.Internal.PersistentImport Database.Esqueleto.Internal.PersistentImport
Database.Esqueleto.PostgreSQL.JSON.Instances Database.Esqueleto.PostgreSQL.JSON.Instances
Paths_esqueleto Paths_esqueleto
hs-source-dirs: hs-source-dirs:
src/ src/
build-depends: build-depends:
base >=4.8 && <5.0 base >=4.8 && <5.0
, aeson >=1.0 , aeson >=1.0
, attoparsec >= 0.13 && < 0.14 , attoparsec >= 0.13 && < 0.14
, blaze-html , blaze-html
, bytestring , bytestring
, conduit >=1.3 , conduit >=1.3
, containers , containers
, monad-logger , monad-logger
, persistent >=2.10.0 && <2.11 , persistent >=2.10.0 && <2.11
, resourcet >=1.2 , resourcet >=1.2
, tagged >=0.2 , tagged >=0.2
, text >=0.11 && <1.3 , text >=0.11 && <1.3
, time >=1.5.0.1 && <=1.10 , time >=1.5.0.1 && <=1.10
, transformers >=0.2 , transformers >=0.2
, unliftio , unliftio
, unordered-containers >=0.2 , unordered-containers >=0.2
if impl(ghc >=8.0) ghc-options:
ghc-options: -Wall -Wno-redundant-constraints -Wall
else -Wno-redundant-constraints
ghc-options: -Wall -Wincomplete-uni-patterns
default-language: Haskell2010 -Wincomplete-record-updates
-Wpartial-fields
-Wmissing-home-modules
-Widentities
-Wredundant-constraints
-Wcpp-undef
-Wcpp-undef
-Wmonomorphism-restriction
default-language: Haskell2010
test-suite mysql test-suite mysql
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: MySQL/Test.hs main-is: MySQL/Test.hs
other-modules: other-modules:
Common.Test Common.Test
Paths_esqueleto Paths_esqueleto
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >=4.8 && <5.0 base >=4.8 && <5.0
, attoparsec , attoparsec
, blaze-html , blaze-html
, bytestring , bytestring
, conduit >=1.3 , conduit >=1.3
, containers , containers
, esqueleto , esqueleto
, exceptions , exceptions
, hspec , hspec
, monad-logger , monad-logger
, mtl , mtl
, mysql , mysql
, mysql-simple , mysql-simple
, persistent >=2.8.0 && <2.11 , persistent >=2.8.0 && <2.11
, persistent-mysql , persistent-mysql
, persistent-template , persistent-template
, resourcet >=1.2 , resourcet >=1.2
, tagged >=0.2 , tagged >=0.2
, text >=0.11 && <1.3 , text >=0.11 && <1.3
, time , time
, transformers >=0.2 , transformers >=0.2
, unliftio , unliftio
, unordered-containers >=0.2 , unordered-containers >=0.2
default-language: Haskell2010 default-language: Haskell2010
test-suite postgresql test-suite postgresql
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: PostgreSQL/Test.hs main-is: PostgreSQL/Test.hs
other-modules: other-modules:
Common.Test Common.Test
PostgreSQL.MigrateJSON PostgreSQL.MigrateJSON
Paths_esqueleto Paths_esqueleto
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >=4.8 && <5.0 base >=4.8 && <5.0
, aeson , aeson
, attoparsec , attoparsec
, blaze-html , blaze-html
, bytestring , bytestring
, conduit >=1.3 , conduit >=1.3
, containers , containers
, esqueleto , esqueleto
, exceptions , exceptions
, hspec , hspec
, monad-logger , monad-logger
, mtl , mtl
, persistent >=2.10.0 && <2.11 , persistent >=2.10.0 && <2.11
, persistent-postgresql >= 2.10.0 && <2.11 , persistent-postgresql >= 2.10.0 && <2.11
, persistent-template , persistent-template
, postgresql-libpq , postgresql-libpq
, postgresql-simple , postgresql-simple
, resourcet >=1.2 , resourcet >=1.2
, tagged >=0.2 , tagged >=0.2
, text >=0.11 && <1.3 , text >=0.11 && <1.3
, time , time
, transformers >=0.2 , transformers >=0.2
, unliftio , unliftio
, unordered-containers >=0.2 , unordered-containers >=0.2
, vector , vector
default-language: Haskell2010 default-language: Haskell2010
test-suite sqlite test-suite sqlite
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
main-is: SQLite/Test.hs main-is: SQLite/Test.hs
other-modules: other-modules:
Common.Test Common.Test
Paths_esqueleto Paths_esqueleto
hs-source-dirs: hs-source-dirs:
test test
ghc-options: -Wall ghc-options: -Wall
build-depends: build-depends:
base >=4.8 && <5.0 base >=4.8 && <5.0
, attoparsec , attoparsec
, blaze-html , blaze-html
, bytestring , bytestring
, conduit >=1.3 , conduit >=1.3
, containers , containers
, esqueleto , esqueleto
, exceptions , exceptions
, hspec , hspec
, monad-logger , monad-logger
, mtl , mtl
, persistent >=2.8.0 && <2.11 , persistent >=2.8.0 && <2.11
, persistent-sqlite , persistent-sqlite
, persistent-template , persistent-template
, resourcet >=1.2 , resourcet >=1.2
, tagged >=0.2 , tagged >=0.2
, text >=0.11 && <1.3 , text >=0.11 && <1.3
, time , time
, transformers >=0.2 , transformers >=0.2
, unliftio , unliftio
, unordered-containers >=0.2 , unordered-containers >=0.2
default-language: Haskell2010 default-language: Haskell2010

File diff suppressed because it is too large Load Diff

View File

@ -1,21 +1,21 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
-- | This is an internal module. This module may have breaking changes without -- | This is an internal module. This module may have breaking changes without
-- a corresponding major version bump. If you use this module, please open an -- a corresponding major version bump. If you use this module, please open an
-- issue with your use-case so we can safely support it. -- issue with your use-case so we can safely support it.
module Database.Esqueleto.Internal.ExprParser where module Database.Esqueleto.Internal.ExprParser where
import Prelude hiding (takeWhile) import Prelude hiding (takeWhile)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad (void) import Control.Monad (void)
import Data.Attoparsec.Text import Data.Attoparsec.Text
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Database.Persist.Sql import Database.Persist.Sql
-- | A type representing the access of a table value. In Esqueleto, we get -- | A type representing the access of a table value. In Esqueleto, we get
-- a guarantee that the access will look something like: -- a guarantee that the access will look something like:
@ -26,54 +26,54 @@ import Database.Persist.Sql
-- table name column name -- table name column name
-- @ -- @
data TableAccess = TableAccess data TableAccess = TableAccess
{ tableAccessTable :: Text { tableAccessTable :: Text
, tableAccessColumn :: Text , tableAccessColumn :: Text
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
-- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of -- | Parse a @SqlExpr (Value Bool)@'s textual representation into a list of
-- 'TableAccess' -- 'TableAccess'
parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess) parseOnExpr :: SqlBackend -> Text -> Either String (Set TableAccess)
parseOnExpr sqlBackend text = do parseOnExpr sqlBackend text = do
c <- mkEscapeChar sqlBackend c <- mkEscapeChar sqlBackend
parseOnly (onExpr c) text parseOnly (onExpr c) text
-- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an -- | This function uses the 'connEscapeName' function in the 'SqlBackend' with an
-- empty identifier to pull out an escape character. This implementation works -- empty identifier to pull out an escape character. This implementation works
-- with postgresql, mysql, and sqlite backends. -- with postgresql, mysql, and sqlite backends.
mkEscapeChar :: SqlBackend -> Either String Char mkEscapeChar :: SqlBackend -> Either String Char
mkEscapeChar sqlBackend = mkEscapeChar sqlBackend =
case Text.uncons (connEscapeName sqlBackend (DBName "")) of case Text.uncons (connEscapeName sqlBackend (DBName "")) of
Nothing -> Nothing ->
Left "Failed to get an escape character from the SQL backend." Left "Failed to get an escape character from the SQL backend."
Just (c, _) -> Just (c, _) ->
Right c Right c
type ExprParser a = Char -> Parser a type ExprParser a = Char -> Parser a
onExpr :: ExprParser (Set TableAccess) onExpr :: ExprParser (Set TableAccess)
onExpr e = Set.fromList <$> many' tableAccesses onExpr e = Set.fromList <$> many' tableAccesses
where where
tableAccesses = do tableAccesses = do
skipToEscape e <?> "Skipping to an escape char" skipToEscape e <?> "Skipping to an escape char"
parseTableAccess e <?> "Parsing a table access" parseTableAccess e <?> "Parsing a table access"
skipToEscape :: ExprParser () skipToEscape :: ExprParser ()
skipToEscape escapeChar = void (takeWhile (/= escapeChar)) skipToEscape escapeChar = void (takeWhile (/= escapeChar))
parseEscapedIdentifier :: ExprParser [Char] parseEscapedIdentifier :: ExprParser [Char]
parseEscapedIdentifier escapeChar = do parseEscapedIdentifier escapeChar = do
char escapeChar char escapeChar
str <- parseEscapedChars escapeChar str <- parseEscapedChars escapeChar
char escapeChar char escapeChar
pure str pure str
parseTableAccess :: ExprParser TableAccess parseTableAccess :: ExprParser TableAccess
parseTableAccess ec = do parseTableAccess ec = do
tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec tableAccessTable <- Text.pack <$> parseEscapedIdentifier ec
_ <- char '.' _ <- char '.'
tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec tableAccessColumn <- Text.pack <$> parseEscapedIdentifier ec
pure TableAccess {..} pure TableAccess {..}
parseEscapedChars :: ExprParser [Char] parseEscapedChars :: ExprParser [Char]
parseEscapedChars escapeChar = go parseEscapedChars escapeChar = go

File diff suppressed because it is too large Load Diff

View File

@ -1,69 +1,140 @@
{-# LANGUAGE DeriveDataTypeable {-# LANGUAGE DeriveDataTypeable #-}
, EmptyDataDecls {-# LANGUAGE EmptyDataDecls #-}
, FlexibleContexts {-# LANGUAGE FlexibleContexts #-}
, FlexibleInstances {-# LANGUAGE FlexibleInstances #-}
, FunctionalDependencies {-# LANGUAGE FunctionalDependencies #-}
, MultiParamTypeClasses {-# LANGUAGE GADTs #-}
, TypeFamilies {-# LANGUAGE MultiParamTypeClasses #-}
, UndecidableInstances {-# LANGUAGE TypeFamilies #-}
, GADTs {-# LANGUAGE UndecidableInstances #-}
#-}
-- | This is an internal module, anything exported by this module -- | This is an internal module, anything exported by this module
-- may change without a major version bump. Please use only -- may change without a major version bump. Please use only
-- "Database.Esqueleto" if possible. -- "Database.Esqueleto" if possible.
--
-- This module is deprecated as of 3.4.0.1, and will be removed in 3.5.0.0.
module Database.Esqueleto.Internal.Language module Database.Esqueleto.Internal.Language
( -- * The pretty face {-# DEPRECATED "Use Database.Esqueleto.Internal.Internal instead. This module will be removed in 3.5.0.0 " #-}
from ( -- * The pretty face
, Value(..) from
, ValueList(..) , Value(..)
, SomeValue(..) , ValueList(..)
, ToSomeValues(..) , SomeValue(..)
, InnerJoin(..) , ToSomeValues(..)
, CrossJoin(..) , InnerJoin(..)
, LeftOuterJoin(..) , CrossJoin(..)
, RightOuterJoin(..) , LeftOuterJoin(..)
, FullOuterJoin(..) , RightOuterJoin(..)
, OnClauseWithoutMatchingJoinException(..) , FullOuterJoin(..)
, OrderBy , OnClauseWithoutMatchingJoinException(..)
, DistinctOn , OrderBy
, Update , DistinctOn
, Insertion , Update
, LockingKind(..) , Insertion
, SqlString , LockingKind(..)
, ToBaseId(..) , SqlString
-- * The guts , ToBaseId(..)
, JoinKind(..) -- * The guts
, IsJoinKind(..) , JoinKind(..)
, BackendCompatible(..) , IsJoinKind(..)
, PreprocessedFrom , BackendCompatible(..)
, From , PreprocessedFrom
, FromPreprocess , From
, when_ , FromPreprocess
, then_ , when_
, else_ , then_
, where_, on, groupBy, orderBy, rand, asc, desc, limit, offset , else_
, distinct, distinctOn, don, distinctOnOrderBy, having, locking , where_
, sub_select, (^.), (?.) , on
, val, isNothing, just, nothing, joinV, withNonNull , groupBy
, countRows, count, countDistinct , orderBy
, not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , rand
, between, (+.), (-.), (/.), (*.) , asc
, random_, round_, ceiling_, floor_ , desc
, min_, max_, sum_, avg_, castNum, castNumM , limit
, coalesce, coalesceDefault , offset
, lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ , distinct
, like, ilike, (%), concat_, (++.), castString , distinctOn
, subList_select, valList, justList , don
, in_, notIn, exists, notExists , distinctOnOrderBy
, set, (=.), (+=.), (-=.), (*=.), (/=.) , having
, case_, toBaseId, (<#), (<&>) , locking
, subSelect , sub_select
, subSelectMaybe , (^.)
, subSelectCount , (?.)
, subSelectList , val
, subSelectForeign , isNothing
, subSelectUnsafe , just
) where , nothing
, joinV
, withNonNull
, countRows
, count
, countDistinct
, not_
, (==.)
, (>=.)
, (>.)
, (<=.)
, (<.)
, (!=.)
, (&&.)
, (||.)
, between
, (+.)
, (-.)
, (/.)
, (*.)
, random_
, round_
, ceiling_
, floor_
, min_
, max_
, sum_
, avg_
, castNum
, castNumM
, coalesce
, coalesceDefault
, lower_
, upper_
, trim_
, ltrim_
, rtrim_
, length_
, left_
, right_
, like
, ilike
, (%)
, concat_
, (++.)
, castString
, subList_select
, valList
, justList
, in_
, notIn
, exists
, notExists
, set
, (=.)
, (+=.)
, (-=.)
, (*=.)
, (/=.)
, case_
, toBaseId
, (<#)
, (<&>)
, subSelect
, subSelectMaybe
, subSelectCount
, subSelectList
, subSelectForeign
, subSelectUnsafe
) where
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Internal import Database.Esqueleto.Internal.Internal
import Database.Esqueleto.Internal.PersistentImport

View File

@ -3,148 +3,175 @@
module Database.Esqueleto.Internal.PersistentImport module Database.Esqueleto.Internal.PersistentImport
-- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276 -- NOTE: switch back to a module export once https://gitlab.haskell.org/ghc/ghc/merge_requests/276
-- has been merged. See https://github.com/bitemyapp/esqueleto/issues/110 for more details -- has been merged. See https://github.com/bitemyapp/esqueleto/issues/110 for more details
( toJsonText, ( toJsonText,
entityIdFromJSON, entityIdFromJSON,
entityIdToJSON, entityIdToJSON,
entityValues, entityValues,
fromPersistValueJSON, fromPersistValueJSON,
keyValueEntityFromJSON, keyValueEntityFromJSON,
keyValueEntityToJSON, keyValueEntityToJSON,
toPersistValueJSON, toPersistValueJSON,
selectKeys, selectKeys,
belongsTo, belongsTo,
belongsToJust, belongsToJust,
getEntity, getEntity,
getJust, getJust,
getJustEntity, getJustEntity,
insertEntity, insertEntity,
insertRecord, insertRecord,
liftPersist, liftPersist,
checkUnique, checkUnique,
getByValue, getByValue,
insertBy, insertBy,
insertUniqueEntity, insertUniqueEntity,
onlyUnique, onlyUnique,
replaceUnique, replaceUnique,
transactionSave, transactionSave,
transactionUndo, transactionUndo,
defaultAttribute, defaultAttribute,
mkColumns, mkColumns,
getMigration, getMigration,
migrate, migrate,
parseMigration, parseMigration,
parseMigration', parseMigration',
printMigration, printMigration,
runMigration, runMigration,
runMigrationSilent, runMigrationSilent,
runMigrationUnsafe, runMigrationUnsafe,
showMigration, showMigration,
decorateSQLWithLimitOffset, decorateSQLWithLimitOffset,
fieldDBName, fieldDBName,
fromSqlKey, fromSqlKey,
getFieldName, getFieldName,
getTableName, getTableName,
tableDBName, tableDBName,
toSqlKey, toSqlKey,
withRawQuery, withRawQuery,
getStmtConn, getStmtConn,
rawExecute, rawExecute,
rawExecuteCount, rawExecuteCount,
rawQuery, rawQuery,
rawQueryRes, rawQueryRes,
rawSql, rawSql,
askLogFunc, askLogFunc,
close', close',
createSqlPool, createSqlPool,
liftSqlPersistMPool, liftSqlPersistMPool,
runSqlConn, runSqlConn,
runSqlPersistM, runSqlPersistM,
runSqlPersistMPool, runSqlPersistMPool,
runSqlPool, runSqlPool,
withSqlConn, withSqlConn,
withSqlPool, withSqlPool,
readToUnknown, readToUnknown,
readToWrite, readToWrite,
writeToUnknown, writeToUnknown,
entityKeyFields, entityKeyFields,
entityPrimary, entityPrimary,
fromPersistValueText, fromPersistValueText,
keyAndEntityFields, keyAndEntityFields,
toEmbedEntityDef, toEmbedEntityDef,
PersistStore, PersistStore,
PersistUnique, PersistUnique,
DeleteCascade(..), DeleteCascade(..),
PersistConfig(..), PersistConfig(..),
BackendSpecificUpdate, BackendSpecificUpdate,
Entity(..), Entity(..),
PersistEntity(..), PersistEntity(..),
PersistField(..), PersistField(..),
SomePersistField(..), SomePersistField(..),
PersistQueryRead(..), PersistQueryRead(..),
PersistQueryWrite(..), PersistQueryWrite(..),
BackendCompatible(..), BackendCompatible(..),
BackendKey(..), BackendKey(..),
HasPersistBackend(..), HasPersistBackend(..),
IsPersistBackend, IsPersistBackend,
PersistCore(..), PersistCore(..),
PersistRecordBackend, PersistRecordBackend,
PersistStoreRead(..), PersistStoreRead(..),
PersistStoreWrite(..), PersistStoreWrite(..),
ToBackendKey(..), ToBackendKey(..),
PersistUniqueRead(..), PersistUniqueRead(..),
PersistUniqueWrite(..), PersistUniqueWrite(..),
PersistFieldSql(..), PersistFieldSql(..),
RawSql(..), RawSql(..),
CautiousMigration, CautiousMigration,
Column(..), Column(..),
ConnectionPool, ConnectionPool,
Migration, Migration,
PersistentSqlException(..), PersistentSqlException(..),
Single(..), Single(..),
Sql, Sql,
SqlPersistM, SqlPersistM,
SqlPersistT, SqlPersistT,
InsertSqlResult(..), InsertSqlResult(..),
IsSqlBackend, IsSqlBackend,
LogFunc, LogFunc,
SqlBackend(..), SqlBackend(..),
SqlBackendCanRead, SqlBackendCanRead,
SqlBackendCanWrite, SqlBackendCanWrite,
SqlReadBackend(..), SqlReadBackend(..),
SqlReadT, SqlReadT,
SqlWriteBackend(..), SqlWriteBackend(..),
SqlWriteT, SqlWriteT,
Statement(..), Statement(..),
Attr, Attr,
Checkmark(..), Checkmark(..),
CompositeDef(..), CompositeDef(..),
DBName(..), DBName(..),
EmbedEntityDef(..), EmbedEntityDef(..),
EmbedFieldDef(..), EmbedFieldDef(..),
EntityDef(..), EntityDef(..),
ExtraLine, ExtraLine,
FieldDef(..), FieldDef(..),
FieldType(..), FieldType(..),
ForeignDef(..), ForeignDef(..),
ForeignFieldDef, ForeignFieldDef,
HaskellName(..), HaskellName(..),
IsNullable(..), IsNullable(..),
OnlyUniqueException(..), OnlyUniqueException(..),
PersistException(..), PersistException(..),
PersistFilter(..), PersistFilter(..),
PersistUpdate(..), PersistUpdate(..),
PersistValue(..), PersistValue(..),
ReferenceDef(..), ReferenceDef(..),
SqlType(..), SqlType(..),
UniqueDef(..), UniqueDef(..),
UpdateException(..), UpdateException(..),
WhyNullable(..) WhyNullable(..)
) where ) where
import Database.Persist.Sql hiding import Database.Persist.Sql hiding
( BackendSpecificFilter, Filter(..), PersistQuery, SelectOpt(..) ( BackendSpecificFilter
, Update(..), delete, deleteWhereCount, updateWhereCount, selectList , Filter(..)
, selectKeysList, deleteCascadeWhere, (=.), (+=.), (-=.), (*=.), (/=.) , PersistQuery
, (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.) , SelectOpt(..)
, listToJSON, mapToJSON, getPersistMap, limitOffsetOrder, selectSource , Update(..)
, update , count ) , count
, delete
, deleteCascadeWhere
, deleteWhereCount
, getPersistMap
, limitOffsetOrder
, listToJSON
, mapToJSON
, selectKeysList
, selectList
, selectSource
, update
, updateWhereCount
, (!=.)
, (*=.)
, (+=.)
, (-=.)
, (/<-.)
, (/=.)
, (<-.)
, (<.)
, (<=.)
, (=.)
, (==.)
, (>.)
, (>=.)
, (||.)
)

View File

@ -1,82 +1,78 @@
{-# LANGUAGE DeriveDataTypeable {-# LANGUAGE CPP #-}
, EmptyDataDecls {-# LANGUAGE ConstraintKinds #-}
, FlexibleContexts {-# LANGUAGE DeriveDataTypeable #-}
, FlexibleInstances {-# LANGUAGE EmptyDataDecls #-}
, FunctionalDependencies {-# LANGUAGE FlexibleContexts #-}
, MultiParamTypeClasses {-# LANGUAGE FlexibleInstances #-}
, TypeFamilies {-# LANGUAGE FunctionalDependencies #-}
, UndecidableInstances {-# LANGUAGE GADTs #-}
, GADTs {-# LANGUAGE InstanceSigs #-}
#-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds {-# LANGUAGE OverloadedStrings #-}
, EmptyDataDecls {-# LANGUAGE Rank2Types #-}
, FlexibleContexts {-# LANGUAGE ScopedTypeVariables #-}
, FlexibleInstances {-# LANGUAGE TypeFamilies #-}
, FunctionalDependencies {-# LANGUAGE UndecidableInstances #-}
, GADTs
, MultiParamTypeClasses
, OverloadedStrings
, UndecidableInstances
, ScopedTypeVariables
, InstanceSigs
, Rank2Types
, CPP
#-}
-- | This is an internal module, anything exported by this module -- | This is an internal module, anything exported by this module
-- may change without a major version bump. Please use only -- may change without a major version bump. Please use only
-- "Database.Esqueleto" if possible. -- "Database.Esqueleto" if possible.
--
-- This module is deprecated as of 3.4.0.1, and will be removed in 3.5.0.0.
module Database.Esqueleto.Internal.Sql module Database.Esqueleto.Internal.Sql
( -- * The pretty face {-# DEPRECATED "Use Database.Esqueleto.Internal.Internal instead. This module will be removed in 3.5.0.0 " #-}
SqlQuery ( -- * The pretty face
, SqlExpr(..) SqlQuery
, SqlEntity , SqlExpr(..)
, select , SqlEntity
, selectSource , select
, delete , selectSource
, deleteCount , delete
, update , deleteCount
, updateCount , update
, insertSelect , updateCount
, insertSelectCount , insertSelect
-- * The guts , insertSelectCount
, unsafeSqlCase -- * The guts
, unsafeSqlBinOp , unsafeSqlCase
, unsafeSqlBinOpComposite , unsafeSqlBinOp
, unsafeSqlValue , unsafeSqlBinOpComposite
, unsafeSqlCastAs , unsafeSqlValue
, unsafeSqlFunction , unsafeSqlCastAs
, unsafeSqlExtractSubField , unsafeSqlFunction
, UnsafeSqlFunctionArgument , unsafeSqlExtractSubField
, OrderByClause , UnsafeSqlFunctionArgument
, rawSelectSource , OrderByClause
, runSource , rawSelectSource
, rawEsqueleto , runSource
, toRawSql , rawEsqueleto
, Mode(..) , toRawSql
, NeedParens(..) , Mode(..)
, IdentState , NeedParens(..)
, renderExpr , IdentState
, initialIdentState , renderExpr
, IdentInfo , initialIdentState
, SqlSelect(..) , IdentInfo
, veryUnsafeCoerceSqlExprValue , SqlSelect(..)
, veryUnsafeCoerceSqlExprValueList , veryUnsafeCoerceSqlExprValue
-- * Helper functions , veryUnsafeCoerceSqlExprValueList
, renderQueryToText -- * Helper functions
, renderQuerySelect , renderQueryToText
, renderQueryUpdate , renderQuerySelect
, renderQueryDelete , renderQueryUpdate
, renderQueryInsertInto , renderQueryDelete
, makeOrderByNoNewline , renderQueryInsertInto
, uncommas' , makeOrderByNoNewline
, parens , uncommas'
, toArgList , parens
, builderToText , toArgList
, Ident(..) , builderToText
, valkey , Ident(..)
, valJ , valkey
, deleteKey , valJ
, associateJoin , deleteKey
) where , associateJoin
) where
import Database.Esqueleto.Internal.Internal import Database.Esqueleto.Internal.Internal

View File

@ -1,14 +1,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | This module contain MySQL-specific functions. -- | This module contain MySQL-specific functions.
-- --
-- /Since: 2.2.8/ -- @since 2.2.8
module Database.Esqueleto.MySQL module Database.Esqueleto.MySQL
( random_ ( random_
) where ) where
import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
-- | (@random()@) Split out into database specific modules -- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.

View File

@ -1,59 +1,56 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings {-# LANGUAGE GADTs #-}
, GADTs, CPP, Rank2Types {-# LANGUAGE OverloadedStrings #-}
, ScopedTypeVariables {-# LANGUAGE Rank2Types #-}
#-} {-# LANGUAGE ScopedTypeVariables #-}
-- | This module contain PostgreSQL-specific functions. -- | This module contain PostgreSQL-specific functions.
-- --
-- /Since: 2.2.8/ -- @since: 2.2.8
module Database.Esqueleto.PostgreSQL module Database.Esqueleto.PostgreSQL
( AggMode(..) ( AggMode(..)
, arrayAggDistinct , arrayAggDistinct
, arrayAgg , arrayAgg
, arrayAggWith , arrayAggWith
, arrayRemove , arrayRemove
, arrayRemoveNull , arrayRemoveNull
, stringAgg , stringAgg
, stringAggWith , stringAggWith
, maybeArray , maybeArray
, chr , chr
, now_ , now_
, random_ , random_
, upsert , upsert
, upsertBy , upsertBy
, insertSelectWithConflict , insertSelectWithConflict
, insertSelectWithConflictCount , insertSelectWithConflictCount
, filterWhere , filterWhere
-- * Internal -- * Internal
, unsafeSqlAggregateFunction , unsafeSqlAggregateFunction
) where ) where
#if __GLASGOW_HASKELL__ < 804 #if __GLASGOW_HASKELL__ < 804
import Data.Semigroup import Data.Semigroup
#endif #endif
import qualified Data.Text.Internal.Builder as TLB import Control.Arrow (first, (***))
import Data.Time.Clock (UTCTime) import Control.Exception (throw)
import Database.Esqueleto.Internal.Language hiding (random_) import Control.Monad (void)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Control.Monad.IO.Class (MonadIO(..))
import Database.Esqueleto.Internal.Sql import qualified Control.Monad.Trans.Reader as R
import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..), import Data.Int (Int64)
UnexpectedCaseError(..), SetClause, Ident(..), import Data.List.NonEmpty (NonEmpty((:|)))
uncommas, FinalResult(..), toUniqueDef, import Data.Proxy (Proxy(..))
KnowResult, renderUpdates, UnexpectedValueError(..)) import qualified Data.Text.Internal.Builder as TLB
import Database.Persist.Class (OnlyOneUniqueKey) import Data.Time.Clock (UTCTime)
import Data.List.NonEmpty ( NonEmpty( (:|) ) ) import Database.Esqueleto.Internal.Internal hiding (random_)
import Data.Int (Int64) import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Data.Proxy (Proxy(..)) import Database.Persist.Class (OnlyOneUniqueKey)
import Control.Arrow ((***), first)
import Control.Exception (throw)
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..))
import qualified Control.Monad.Trans.Reader as R
-- | (@random()@) Split out into database specific modules -- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.
-- --
-- /Since: 2.6.0/ -- @since 2.6.0
random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ :: (PersistField a, Num a) => SqlExpr (Value a)
random_ = unsafeSqlValue "RANDOM()" random_ = unsafeSqlValue "RANDOM()"
@ -69,45 +66,48 @@ maybeArray ::
maybeArray x = coalesceDefault [x] (emptyArray) maybeArray x = coalesceDefault [x] (emptyArray)
-- | Aggregate mode -- | Aggregate mode
data AggMode = AggModeAll -- ^ ALL data AggMode
| AggModeDistinct -- ^ DISTINCT = AggModeAll -- ^ ALL
deriving (Show) | AggModeDistinct -- ^ DISTINCT
deriving (Show)
-- | (Internal) Create a custom aggregate functions with aggregate mode -- | (Internal) Create a custom aggregate functions with aggregate mode
-- --
-- /Do/ /not/ use this function directly, instead define a new function and give -- /Do/ /not/ use this function directly, instead define a new function and give
-- it a type (see `unsafeSqlBinOp`) -- it a type (see `unsafeSqlBinOp`)
unsafeSqlAggregateFunction :: unsafeSqlAggregateFunction
UnsafeSqlFunctionArgument a :: UnsafeSqlFunctionArgument a
=> TLB.Builder => TLB.Builder
-> AggMode -> AggMode
-> a -> a
-> [OrderByClause] -> [OrderByClause]
-> SqlExpr (Value b) -> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses = unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info ->
ERaw Never $ \info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
-- Don't add a space if we don't have order by clauses -- Don't add a space if we don't have order by clauses
orderTLBSpace = case orderByClauses of orderTLBSpace =
[] -> "" case orderByClauses of
(_:_) -> " " [] -> ""
(_:_) -> " "
(argsTLB, argsVals) = (argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args
aggMode = case mode of aggMode =
AggModeAll -> "" -- ALL is the default, so we don't need to case mode of
-- specify it AggModeAll -> ""
AggModeDistinct -> "DISTINCT " -- ALL is the default, so we don't need to
-- specify it
AggModeDistinct -> "DISTINCT "
in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB) in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB)
, argsVals <> orderVals , argsVals <> orderVals
) )
--- | (@array_agg@) Concatenate input values, including @NULL@s, --- | (@array_agg@) Concatenate input values, including @NULL@s,
--- into an array. --- into an array.
arrayAggWith :: arrayAggWith
AggMode :: AggMode
-> SqlExpr (Value a) -> SqlExpr (Value a)
-> [OrderByClause] -> [OrderByClause]
-> SqlExpr (Value (Maybe [a])) -> SqlExpr (Value (Maybe [a]))
arrayAggWith = unsafeSqlAggregateFunction "array_agg" arrayAggWith = unsafeSqlAggregateFunction "array_agg"
--- | (@array_agg@) Concatenate input values, including @NULL@s, --- | (@array_agg@) Concatenate input values, including @NULL@s,
@ -118,18 +118,17 @@ arrayAgg x = arrayAggWith AggModeAll x []
-- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into -- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into
-- an array. -- an array.
-- --
-- /Since: 2.5.3/ -- @since 2.5.3
arrayAggDistinct :: arrayAggDistinct
(PersistField a, PersistField [a]) :: (PersistField a, PersistField [a])
=> SqlExpr (Value a) => SqlExpr (Value a)
-> SqlExpr (Value (Maybe [a])) -> SqlExpr (Value (Maybe [a]))
arrayAggDistinct x = arrayAggWith AggModeDistinct x [] arrayAggDistinct x = arrayAggWith AggModeDistinct x []
-- | (@array_remove@) Remove all elements equal to the given value from the -- | (@array_remove@) Remove all elements equal to the given value from the
-- array. -- array.
-- --
-- /Since: 2.5.3/ -- @since 2.5.3
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a]) arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem') arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')
@ -154,7 +153,7 @@ stringAggWith mode expr delim os =
-- | (@string_agg@) Concatenate input values separated by a -- | (@string_agg@) Concatenate input values separated by a
-- delimiter. -- delimiter.
-- --
-- /Since: 2.2.8/ -- @since 2.2.8
stringAgg :: stringAgg ::
SqlString s SqlString s
=> SqlExpr (Value s) -- ^ Input values. => SqlExpr (Value s) -- ^ Input values.
@ -165,18 +164,21 @@ stringAgg expr delim = stringAggWith AggModeAll expr delim []
-- | (@chr@) Translate the given integer to a character. (Note the result will -- | (@chr@) Translate the given integer to a character. (Note the result will
-- depend on the character set of your database.) -- depend on the character set of your database.)
-- --
-- /Since: 2.2.11/ -- @since 2.2.11
chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s)
chr = unsafeSqlFunction "chr" chr = unsafeSqlFunction "chr"
now_ :: SqlExpr (Value UTCTime) now_ :: SqlExpr (Value UTCTime)
now_ = unsafeSqlFunction "NOW" () now_ = unsafeSqlFunction "NOW" ()
upsert :: (MonadIO m, upsert
PersistEntity record, ::
OnlyOneUniqueKey record, ( MonadIO m
PersistRecordBackend record SqlBackend, , PersistEntity record
IsPersistBackend (PersistEntityBackend record)) , OnlyOneUniqueKey record
, PersistRecordBackend record SqlBackend
, IsPersistBackend (PersistEntityBackend record)
)
=> record => record
-- ^ new record to insert -- ^ new record to insert
-> [SqlExpr (Update record)] -> [SqlExpr (Update record)]
@ -187,30 +189,33 @@ upsert record updates = do
uniqueKey <- onlyUnique record uniqueKey <- onlyUnique record
upsertBy uniqueKey record updates upsertBy uniqueKey record updates
upsertBy :: (MonadIO m, upsertBy
PersistEntity record, ::
IsPersistBackend (PersistEntityBackend record)) (MonadIO m
=> Unique record , PersistEntity record
-- ^ uniqueness constraint to find by , IsPersistBackend (PersistEntityBackend record)
-> record )
-- ^ new record to insert => Unique record
-> [SqlExpr (Update record)] -- ^ uniqueness constraint to find by
-- ^ updates to perform if the record already exists -> record
-> R.ReaderT SqlBackend m (Entity record) -- ^ new record to insert
-- ^ the record in the database after the operation -> [SqlExpr (Update record)]
-- ^ updates to perform if the record already exists
-> R.ReaderT SqlBackend m (Entity record)
-- ^ the record in the database after the operation
upsertBy uniqueKey record updates = do upsertBy uniqueKey record updates = do
sqlB <- R.ask sqlB <- R.ask
maybe maybe
(throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent
(handler sqlB) (handler sqlB)
(connUpsertSql sqlB) (connUpsertSql sqlB)
where where
addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey
entDef = entityDef (Just record) entDef = entityDef (Just record)
uDef = toUniqueDef uniqueKey uDef = toUniqueDef uniqueKey
updatesText conn = first builderToText $ renderUpdates conn updates updatesText conn = first builderToText $ renderUpdates conn updates
handler conn f = fmap head $ uncurry rawSql $ handler conn f = fmap head $ uncurry rawSql $
(***) (f entDef (uDef :| [])) addVals $ updatesText conn (***) (f entDef (uDef :| [])) addVals $ updatesText conn
-- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- | Inserts into a table the results of a query similar to 'insertSelect' but allows
-- to update values that violate a constraint during insertions. -- to update values that violate a constraint during insertions.
@ -245,38 +250,39 @@ upsertBy uniqueKey record updates = do
-- the conflicting value is updated to the current plus the excluded. -- the conflicting value is updated to the current plus the excluded.
-- --
-- @since 3.1.3 -- @since 3.1.3
insertSelectWithConflict :: forall a m val. ( insertSelectWithConflict
FinalResult a, :: forall a m val
KnowResult a ~ (Unique val), . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
MonadIO m, => a
PersistEntity val) => -- ^ Unique constructor or a unique, this is used just to get the name of
a -- the postgres constraint, the value(s) is(are) never used, so if you have
-- ^ Unique constructor or a unique, this is used just to get the name of the postgres constraint, the value(s) is(are) never used, so if you have a unique "MyUnique 0", "MyUnique undefined" would work as well. -- a unique "MyUnique 0", "MyUnique undefined" would work as well.
-> SqlQuery (SqlExpr (Insertion val)) -> SqlQuery (SqlExpr (Insertion val))
-- ^ Insert query. -- ^ Insert query.
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-- ^ A list of updates to be applied in case of the constraint being violated. The expression takes the current and excluded value to produce the updates. -- ^ A list of updates to be applied in case of the constraint being
-> SqlWriteT m () -- violated. The expression takes the current and excluded value to produce
insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query -- the updates.
-> SqlWriteT m ()
insertSelectWithConflict unique query =
void . insertSelectWithConflictCount unique query
-- | Same as 'insertSelectWithConflict' but returns the number of rows affected. -- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
-- --
-- @since 3.1.3 -- @since 3.1.3
insertSelectWithConflictCount :: forall a val m. ( insertSelectWithConflictCount
FinalResult a, :: forall a val m
KnowResult a ~ (Unique val), . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
MonadIO m, => a
PersistEntity val) => -> SqlQuery (SqlExpr (Insertion val))
a -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-> SqlQuery (SqlExpr (Insertion val)) -> SqlWriteT m Int64
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-> SqlWriteT m Int64
insertSelectWithConflictCount unique query conflictQuery = do insertSelectWithConflictCount unique query conflictQuery = do
conn <- R.ask conn <- R.ask
uncurry rawExecuteCount $ uncurry rawExecuteCount $
combine combine
(toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query)) (toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))
(conflict conn) (conflict conn)
where where
proxy :: Proxy val proxy :: Proxy val
proxy = Proxy proxy = Proxy
@ -289,7 +295,7 @@ insertSelectWithConflictCount unique query conflictQuery = do
constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef
renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
renderedUpdates conn = renderUpdates conn updates renderedUpdates conn = renderUpdates conn updates
conflict conn = (foldr1 mappend ([ conflict conn = (mconcat ([
TLB.fromText "ON CONFLICT ON CONSTRAINT \"", TLB.fromText "ON CONFLICT ON CONSTRAINT \"",
constraint, constraint,
TLB.fromText "\" DO " TLB.fromText "\" DO "
@ -327,18 +333,18 @@ insertSelectWithConflictCount unique query conflictQuery = do
-- --
-- @since 3.3.3.3 -- @since 3.3.3.3
filterWhere filterWhere
:: SqlExpr (Value a) :: SqlExpr (Value a)
-- ^ Aggregate function -- ^ Aggregate function
-> SqlExpr (Value Bool) -> SqlExpr (Value Bool)
-- ^ Filter clause -- ^ Filter clause
-> SqlExpr (Value a) -> SqlExpr (Value a)
filterWhere aggExpr clauseExpr = ERaw Never $ \info -> filterWhere aggExpr clauseExpr = ERaw Never $ \info ->
let (aggBuilder, aggValues) = case aggExpr of let (aggBuilder, aggValues) = case aggExpr of
ERaw _ aggF -> aggF info ERaw _ aggF -> aggF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError
(clauseBuilder, clauseValues) = case clauseExpr of (clauseBuilder, clauseValues) = case clauseExpr of
ERaw _ clauseF -> clauseF info ERaw _ clauseF -> clauseF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError
in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")" in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
, aggValues <> clauseValues , aggValues <> clauseValues
) )

View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-| {-|
This module contains PostgreSQL-specific JSON functions. This module contains PostgreSQL-specific JSON functions.
@ -22,130 +23,128 @@
@since 3.1.0 @since 3.1.0
-} -}
module Database.Esqueleto.PostgreSQL.JSON module Database.Esqueleto.PostgreSQL.JSON
( -- * JSONB Newtype ( -- * JSONB Newtype
--
-- | With 'JSONB', you can use your Haskell types in your
-- database table models as long as your type has 'FromJSON'
-- and 'ToJSON' instances.
--
-- @
-- import Database.Persist.TH
--
-- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
-- Example
-- json (JSONB MyType)
-- |]
-- @
--
-- CAUTION: Remember that changing the 'FromJSON' instance
-- of your type might result in old data becoming unparsable!
-- You can use (@JSONB Data.Aeson.Value@) for unstructured/variable JSON.
JSONB(..)
, JSONBExpr
, jsonbVal
-- * JSONAccessor
, JSONAccessor(..)
-- * Arrow operators
-- --
-- | With 'JSONB', you can use your Haskell types in your -- | /Better documentation included with individual functions/
-- database table models as long as your type has 'FromJSON' --
-- and 'ToJSON' instances. -- The arrow operators are selection functions to select values
-- from JSON arrays or objects.
--
-- === PostgreSQL Documentation
--
-- /Requires PostgreSQL version >= 9.3/
-- --
-- @ -- @
-- import Database.Persist.TH -- | Type | Description | Example | Example Result
-- -----+--------+--------------------------------------------+--------------------------------------------------+----------------
-- -> | int | Get JSON array element (indexed from zero, | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"}
-- | | negative integers count from the end) | |
-- -> | text | Get JSON object field by key | '{"a": {"b":"foo"}}'::json->'a' | {"b":"foo"}
-- ->> | int | Get JSON array element as text | '[1,2,3]'::json->>2 | 3
-- ->> | text | Get JSON object field as text | '{"a":1,"b":2}'::json->>'b' | 2
-- \#> | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"}
-- \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3
-- @
, (->.)
, (->>.)
, (#>.)
, (#>>.)
-- * Filter operators
-- --
-- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| -- | /Better documentation included with individual functions/
-- Example --
-- json (JSONB MyType) -- These functions test certain properties of JSON values
-- |] -- and return booleans, so are mainly used in WHERE clauses.
--
-- === PostgreSQL Documentation
--
-- /Requires PostgreSQL version >= 9.4/
--
-- @
-- | Type | Description | Example
-- ----+--------+-----------------------------------------------------------------+---------------------------------------------------
-- \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb
-- <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb
-- ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b'
-- ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c']
-- ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b']
-- @
, (@>.)
, (<@.)
, (?.)
, (?|.)
, (?&.)
-- * Deletion and concatenation operators
--
-- | /Better documentation included with individual functions/
--
-- These operators change the shape of the JSON value and
-- also have the highest risk of throwing an exception.
-- Please read the descriptions carefully before using these functions.
--
-- === PostgreSQL Documentation
--
-- /Requires PostgreSQL version >= 9.5/
--
-- @
-- | Type | Description | Example
-- ----+---------+------------------------------------------------------------------------+-------------------------------------------------
-- || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb
-- - | text | Delete key/value pair or string element from left operand. | '{"a": "b"}'::jsonb - 'a'
-- | | Key/value pairs are matched based on their key value. |
-- - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1
-- | | from the end). Throws an error if top level container is not an array. |
-- \#- | text[] | Delete the field or element with specified path | '["a", {"b":1}]'::jsonb \#- '{1,b}'
-- | | (for JSON arrays, negative integers count from the end) |
-- @ -- @
-- --
-- CAUTION: Remember that changing the 'FromJSON' instance -- /Requires PostgreSQL version >= 10/
-- of your type might result in old data becoming unparsable! --
-- You can use (@JSONB Data.Aeson.Value@) for unstructured/variable JSON. -- @
JSONB(..) -- | Type | Description | Example
, JSONBExpr -- ----+---------+------------------------------------------------------------------------+-------------------------------------------------
, jsonbVal -- - | text[] | Delete multiple key/value pairs or string elements from left operand. | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[]
-- * JSONAccessor -- | | Key/value pairs are matched based on their key value. |
, JSONAccessor(..) -- @
-- * Arrow operators , (-.)
-- , (--.)
-- | /Better documentation included with individual functions/ , (#-.)
-- , (||.)
-- The arrow operators are selection functions to select values ) where
-- from JSON arrays or objects.
--
-- === PostgreSQL Documentation
--
-- /Requires PostgreSQL version >= 9.3/
--
-- @
-- | Type | Description | Example | Example Result
-- -----+--------+--------------------------------------------+--------------------------------------------------+----------------
-- -> | int | Get JSON array element (indexed from zero, | '[{"a":"foo"},{"b":"bar"},{"c":"baz"}]'::json->2 | {"c":"baz"}
-- | | negative integers count from the end) | |
-- -> | text | Get JSON object field by key | '{"a": {"b":"foo"}}'::json->'a' | {"b":"foo"}
-- ->> | int | Get JSON array element as text | '[1,2,3]'::json->>2 | 3
-- ->> | text | Get JSON object field as text | '{"a":1,"b":2}'::json->>'b' | 2
-- \#> | text[] | Get JSON object at specified path | '{"a": {"b":{"c": "foo"}}}'::json#>'{a,b}' | {"c": "foo"}
-- \#>> | text[] | Get JSON object at specified path as text | '{"a":[1,2,3],"b":[4,5,6]}'::json#>>'{a,2}' | 3
-- @
, (->.)
, (->>.)
, (#>.)
, (#>>.)
-- * Filter operators
--
-- | /Better documentation included with individual functions/
--
-- These functions test certain properties of JSON values
-- and return booleans, so are mainly used in WHERE clauses.
--
-- === PostgreSQL Documentation
--
-- /Requires PostgreSQL version >= 9.4/
--
-- @
-- | Type | Description | Example
-- ----+--------+-----------------------------------------------------------------+---------------------------------------------------
-- \@> | jsonb | Does the left JSON value contain within it the right value? | '{"a":1, "b":2}'::jsonb \@> '{"b":2}'::jsonb
-- <\@ | jsonb | Is the left JSON value contained within the right value? | '{"b":2}'::jsonb <\@ '{"a":1, "b":2}'::jsonb
-- ? | text | Does the string exist as a top-level key within the JSON value? | '{"a":1, "b":2}'::jsonb ? 'b'
-- ?| | text[] | Do any of these array strings exist as top-level keys? | '{"a":1, "b":2, "c":3}'::jsonb ?| array['b', 'c']
-- ?& | text[] | Do all of these array strings exist as top-level keys? | '["a", "b"]'::jsonb ?& array['a', 'b']
-- @
, (@>.)
, (<@.)
, (?.)
, (?|.)
, (?&.)
-- * Deletion and concatenation operators
--
-- | /Better documentation included with individual functions/
--
-- These operators change the shape of the JSON value and
-- also have the highest risk of throwing an exception.
-- Please read the descriptions carefully before using these functions.
--
-- === PostgreSQL Documentation
--
-- /Requires PostgreSQL version >= 9.5/
--
-- @
-- | Type | Description | Example
-- ----+---------+------------------------------------------------------------------------+-------------------------------------------------
-- || | jsonb | Concatenate two jsonb values into a new jsonb value | '["a", "b"]'::jsonb || '["c", "d"]'::jsonb
-- - | text | Delete key/value pair or string element from left operand. | '{"a": "b"}'::jsonb - 'a'
-- | | Key/value pairs are matched based on their key value. |
-- - | integer | Delete the array element with specified index (Negative integers count | '["a", "b"]'::jsonb - 1
-- | | from the end). Throws an error if top level container is not an array. |
-- \#- | text[] | Delete the field or element with specified path | '["a", {"b":1}]'::jsonb \#- '{1,b}'
-- | | (for JSON arrays, negative integers count from the end) |
-- @
--
-- /Requires PostgreSQL version >= 10/
--
-- @
-- | Type | Description | Example
-- ----+---------+------------------------------------------------------------------------+-------------------------------------------------
-- - | text[] | Delete multiple key/value pairs or string elements from left operand. | '{"a": "b", "c": "d"}'::jsonb - '{a,c}'::text[]
-- | | Key/value pairs are matched based on their key value. |
-- @
, (-.)
, (--.)
, (#-.)
, (||.)
) where
import Data.Text (Text) import Data.Text (Text)
import Database.Esqueleto.Internal.Language hiding ((?.), (-.), (||.)) import Database.Esqueleto.Internal.Language hiding ((-.), (?.), (||.))
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.PostgreSQL.JSON.Instances import Database.Esqueleto.PostgreSQL.JSON.Instances
infixl 6 ->., ->>., #>., #>>. infixl 6 ->., ->>., #>., #>>.
infixl 6 @>., <@., ?., ?|., ?&. infixl 6 @>., <@., ?., ?|., ?&.
infixl 6 ||., -., --., #-. infixl 6 ||., -., --., #-.
-- | /Requires PostgreSQL version >= 9.3/ -- | /Requires PostgreSQL version >= 9.3/
-- --
-- This function extracts the jsonb value from a JSON array or object, -- This function extracts the jsonb value from a JSON array or object,

View File

@ -4,6 +4,8 @@
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# language DerivingStrategies #-}
module Database.Esqueleto.PostgreSQL.JSON.Instances where module Database.Esqueleto.PostgreSQL.JSON.Instances where
import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict) import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict)
@ -18,23 +20,24 @@ import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql (SqlExpr) import Database.Esqueleto.Internal.Sql (SqlExpr)
import GHC.Generics (Generic) import GHC.Generics (Generic)
-- | Newtype wrapper around any type with a JSON representation. -- | Newtype wrapper around any type with a JSON representation.
-- --
-- @since 3.1.0 -- @since 3.1.0
newtype JSONB a = JSONB { unJSONB :: a } newtype JSONB a = JSONB { unJSONB :: a }
deriving deriving stock
( Generic ( Generic
, FromJSON , Eq
, ToJSON , Foldable
, Eq , Functor
, Foldable , Ord
, Functor , Read
, Ord , Show
, Read , Traversable
, Show )
, Traversable deriving newtype
) ( FromJSON
, ToJSON
)
-- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'. -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'.
-- --
@ -60,48 +63,49 @@ jsonbVal = just . val . JSONB
-- JSONKey "name" -- JSONKey "name"
-- --
-- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE! -- NOTE: DO NOT USE ANY OF THE 'Num' METHODS ON THIS TYPE!
data JSONAccessor = JSONIndex Int data JSONAccessor
| JSONKey Text = JSONIndex Int
deriving (Generic, Eq, Show) | JSONKey Text
deriving (Generic, Eq, Show)
-- | I repeat, DO NOT use any method other than 'fromInteger'! -- | I repeat, DO NOT use any method other than 'fromInteger'!
instance Num JSONAccessor where instance Num JSONAccessor where
fromInteger = JSONIndex . fromInteger fromInteger = JSONIndex . fromInteger
negate (JSONIndex i) = JSONIndex $ negate i negate (JSONIndex i) = JSONIndex $ negate i
negate (JSONKey _) = error "Can not negate a JSONKey" negate (JSONKey _) = error "Can not negate a JSONKey"
(+) = numErr (+) = numErr
(-) = numErr (-) = numErr
(*) = numErr (*) = numErr
abs = numErr abs = numErr
signum = numErr signum = numErr
numErr :: a numErr :: a
numErr = error "Do not use 'Num' methods on JSONAccessors" numErr = error "Do not use 'Num' methods on JSONAccessors"
instance IsString JSONAccessor where instance IsString JSONAccessor where
fromString = JSONKey . T.pack fromString = JSONKey . T.pack
-- | @since 3.1.0 -- | @since 3.1.0
instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where
toPersistValue = PersistDbSpecific . BSL.toStrict . encode . unJSONB toPersistValue = PersistDbSpecific . BSL.toStrict . encode . unJSONB
fromPersistValue pVal = fmap JSONB $ case pVal of fromPersistValue pVal = fmap JSONB $ case pVal of
PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs
PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t) PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t)
x -> Left $ fromPersistValueError "string or bytea" x x -> Left $ fromPersistValueError "string or bytea" x
-- | jsonb -- | jsonb
-- --
-- @since 3.1.0 -- @since 3.1.0
instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where instance (FromJSON a, ToJSON a) => PersistFieldSql (JSONB a) where
sqlType _ = SqlOther "JSONB" sqlType _ = SqlOther "JSONB"
badParse :: Text -> String -> Text badParse :: Text -> String -> Text
badParse t = fromPersistValueParseError t . T.pack badParse t = fromPersistValueParseError t . T.pack
fromPersistValueError fromPersistValueError
:: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". :: Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int".
-> PersistValue -- ^ Incorrect value -> PersistValue -- ^ Incorrect value
-> Text -- ^ Error message -> Text -- ^ Error message
fromPersistValueError databaseType received = T.concat fromPersistValueError databaseType received = T.concat
[ "Failed to parse Haskell newtype `JSONB a`; " [ "Failed to parse Haskell newtype `JSONB a`; "
, "expected ", databaseType , "expected ", databaseType
@ -110,9 +114,9 @@ fromPersistValueError databaseType received = T.concat
] ]
fromPersistValueParseError fromPersistValueParseError
:: Text -- ^ Received value :: Text -- ^ Received value
-> Text -- ^ Additional error -> Text -- ^ Additional error
-> Text -- ^ Error message -> Text -- ^ Error message
fromPersistValueParseError received err = T.concat fromPersistValueParseError received err = T.concat
[ "Failed to parse Haskell type `JSONB a`, " [ "Failed to parse Haskell type `JSONB a`, "
, "but received ", received , "but received ", received

View File

@ -1,14 +1,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | This module contain SQLite-specific functions. -- | This module contain SQLite-specific functions.
-- --
-- /Since: 2.2.8/ -- @since 2.2.8
module Database.Esqueleto.SQLite module Database.Esqueleto.SQLite
( random_ ( random_
) where ) where
import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
-- | (@random()@) Split out into database specific modules -- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.

9
style-guide.md Normal file
View File

@ -0,0 +1,9 @@
# Style Guide
- Please use `stylish-haskell` on the project to keep imports consistent and
clean. We have a custom [`.stylish-haskell.yaml`](.stylish-haskell.yaml) file.
You can run `stylish-haskell` from vim with `:%! stylish-haskell`.
- Four space indent.
- Prefer indentation over any other form of alignment.
- If text goes off the screen due to four space indentation, factor out
functions and values into names to reduce indentation.

File diff suppressed because it is too large Load Diff