haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Autoformatting + Stylish Haskell Config (#218)

Browse Source 
* Add stylish-haskell.yaml, update spacing to 4 in configs

* update travis

* lol

* major formatting stuff

* fix parse error

* fix

* warnings, more tidying up

* Add style guide [ci skip]

* faster build perhaps

* cabbal

* sigh
This commit is contained in:
Matt Parsons 2020-10-29 16:20:52 -06:00 committed by GitHub
parent 4f6b02298c
commit b35713c09f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
19 changed files with 3060 additions and 2809 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.editorconfig
View File

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

11
.github/PULL_REQUEST_TEMPLATE.md vendored
View File

@ -1,13 +1,14 @@
Before submitting your PR, check that you've:
- [ ] Bumped the version number
- [ ] 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
- [ ] Bumped the version number.
- [ ] 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.
- [ ] Ran `stylish-haskell` and otherwise adhered to the [style guide](https://github.com/bitemyapp/esqueleto/blob/master/style-guide.yaml).
After submitting 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)
- [ ] 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).
<!---Thanks so much for contributing! :)

8
.github/workflows/haskell.yml vendored
View File

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

5
.travis.yml
View File

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

290
esqueleto.cabal
View File

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

844
src/Database/Esqueleto/Experimental.hs
View File

File diff suppressed because it is too large Load Diff

64
src/Database/Esqueleto/Internal/ExprParser.hs
View File

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

2344
src/Database/Esqueleto/Internal/Internal.hs
View File

File diff suppressed because it is too large Load Diff

197
src/Database/Esqueleto/Internal/Language.hs
View File

@ -1,69 +1,140 @@
{-# LANGUAGE DeriveDataTypeable
, EmptyDataDecls
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, MultiParamTypeClasses
, TypeFamilies
, UndecidableInstances
, GADTs
#-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | This is an internal module, anything exported by this module
-- may change without a major version bump. Please use only
-- "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
( -- * The pretty face
from
, Value(..)
, ValueList(..)
, SomeValue(..)
, ToSomeValues(..)
, InnerJoin(..)
, CrossJoin(..)
, LeftOuterJoin(..)
, RightOuterJoin(..)
, FullOuterJoin(..)
, OnClauseWithoutMatchingJoinException(..)
, OrderBy
, DistinctOn
, Update
, Insertion
, LockingKind(..)
, SqlString
, ToBaseId(..)
-- * The guts
, JoinKind(..)
, IsJoinKind(..)
, BackendCompatible(..)
, PreprocessedFrom
, From
, FromPreprocess
, when_
, then_
, else_
, where_, on, groupBy, orderBy, rand, asc, desc, limit, offset
, distinct, distinctOn, don, distinctOnOrderBy, having, locking
, sub_select, (^.), (?.)
, val, isNothing, just, 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
{-# DEPRECATED "Use Database.Esqueleto.Internal.Internal instead. This module will be removed in 3.5.0.0 " #-}
( -- * The pretty face
from
, Value(..)
, ValueList(..)
, SomeValue(..)
, ToSomeValues(..)
, InnerJoin(..)
, CrossJoin(..)
, LeftOuterJoin(..)
, RightOuterJoin(..)
, FullOuterJoin(..)
, OnClauseWithoutMatchingJoinException(..)
, OrderBy
, DistinctOn
, Update
, Insertion
, LockingKind(..)
, SqlString
, ToBaseId(..)
-- * The guts
, JoinKind(..)
, IsJoinKind(..)
, BackendCompatible(..)
, PreprocessedFrom
, From
, FromPreprocess
, when_
, then_
, else_
, where_
, on
, groupBy
, orderBy
, rand
, asc
, desc
, limit
, offset
, distinct
, distinctOn
, don
, distinctOnOrderBy
, having
, locking
, sub_select
, (^.)
, (?.)
, val
, isNothing
, just
, 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.PersistentImport

313
src/Database/Esqueleto/Internal/PersistentImport.hs
View File

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

148
src/Database/Esqueleto/Internal/Sql.hs
View File

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

10
src/Database/Esqueleto/MySQL.hs
View File

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

292
src/Database/Esqueleto/PostgreSQL.hs
View File

@ -1,59 +1,56 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings
, GADTs, CPP, Rank2Types
, ScopedTypeVariables
#-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module contain PostgreSQL-specific functions.
--
-- /Since: 2.2.8/
-- @since: 2.2.8
module Database.Esqueleto.PostgreSQL
( AggMode(..)
, arrayAggDistinct
, arrayAgg
, arrayAggWith
, arrayRemove
, arrayRemoveNull
, stringAgg
, stringAggWith
, maybeArray
, chr
, now_
, random_
, upsert
, upsertBy
, insertSelectWithConflict
, insertSelectWithConflictCount
, filterWhere
-- * Internal
, unsafeSqlAggregateFunction
) where
( AggMode(..)
, arrayAggDistinct
, arrayAgg
, arrayAggWith
, arrayRemove
, arrayRemoveNull
, stringAgg
, stringAggWith
, maybeArray
, chr
, now_
, random_
, upsert
, upsertBy
, insertSelectWithConflict
, insertSelectWithConflictCount
, filterWhere
-- * Internal
, unsafeSqlAggregateFunction
) where
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup
import Data.Semigroup
#endif
import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.Internal.Internal (EsqueletoError(..), CompositeKeyError(..),
UnexpectedCaseError(..), SetClause, Ident(..),
uncommas, FinalResult(..), toUniqueDef,
KnowResult, renderUpdates, UnexpectedValueError(..))
import Database.Persist.Class (OnlyOneUniqueKey)
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import Data.Int (Int64)
import Data.Proxy (Proxy(..))
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
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
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Proxy (Proxy(..))
import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Persist.Class (OnlyOneUniqueKey)
-- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`.
--
-- /Since: 2.6.0/
-- @since 2.6.0
random_ :: (PersistField a, Num a) => SqlExpr (Value a)
random_ = unsafeSqlValue "RANDOM()"
@ -69,45 +66,48 @@ maybeArray ::
maybeArray x = coalesceDefault [x] (emptyArray)
-- | Aggregate mode
data AggMode = AggModeAll -- ^ ALL
| AggModeDistinct -- ^ DISTINCT
deriving (Show)
data AggMode
= AggModeAll -- ^ ALL
| AggModeDistinct -- ^ DISTINCT
deriving (Show)
-- | (Internal) Create a custom aggregate functions with aggregate mode
--
-- /Do/ /not/ use this function directly, instead define a new function and give
-- it a type (see `unsafeSqlBinOp`)
unsafeSqlAggregateFunction ::
UnsafeSqlFunctionArgument a
=> TLB.Builder
-> AggMode
-> a
-> [OrderByClause]
-> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses =
ERaw Never $ \info ->
unsafeSqlAggregateFunction
:: UnsafeSqlFunctionArgument a
=> TLB.Builder
-> AggMode
-> a
-> [OrderByClause]
-> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
-- Don't add a space if we don't have order by clauses
orderTLBSpace = case orderByClauses of
[] -> ""
(_:_) -> " "
orderTLBSpace =
case orderByClauses of
[] -> ""
(_:_) -> " "
(argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args
aggMode = case mode of
AggModeAll -> "" -- ALL is the default, so we don't need to
-- specify it
AggModeDistinct -> "DISTINCT "
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args
aggMode =
case mode of
AggModeAll -> ""
-- ALL is the default, so we don't need to
-- specify it
AggModeDistinct -> "DISTINCT "
in ( name <> parens (aggMode <> argsTLB <> orderTLBSpace <> orderTLB)
, argsVals <> orderVals
)
--- | (@array_agg@) Concatenate input values, including @NULL@s,
--- into an array.
arrayAggWith ::
AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
arrayAggWith
:: AggMode
-> SqlExpr (Value a)
-> [OrderByClause]
-> SqlExpr (Value (Maybe [a]))
arrayAggWith = unsafeSqlAggregateFunction "array_agg"
--- | (@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
-- an array.
--
-- /Since: 2.5.3/
arrayAggDistinct ::
(PersistField a, PersistField [a])
=> SqlExpr (Value a)
-> SqlExpr (Value (Maybe [a]))
-- @since 2.5.3
arrayAggDistinct
:: (PersistField a, PersistField [a])
=> SqlExpr (Value a)
-> SqlExpr (Value (Maybe [a]))
arrayAggDistinct x = arrayAggWith AggModeDistinct x []
-- | (@array_remove@) Remove all elements equal to the given value from the
-- array.
--
-- /Since: 2.5.3/
-- @since 2.5.3
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a])
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
-- delimiter.
--
-- /Since: 2.2.8/
-- @since 2.2.8
stringAgg ::
SqlString s
=> 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
-- 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 = unsafeSqlFunction "chr"
now_ :: SqlExpr (Value UTCTime)
now_ = unsafeSqlFunction "NOW" ()
upsert :: (MonadIO m,
PersistEntity record,
OnlyOneUniqueKey record,
PersistRecordBackend record SqlBackend,
IsPersistBackend (PersistEntityBackend record))
upsert
::
( MonadIO m
, PersistEntity record
, OnlyOneUniqueKey record
, PersistRecordBackend record SqlBackend
, IsPersistBackend (PersistEntityBackend record)
)
=> record
-- ^ new record to insert
-> [SqlExpr (Update record)]
@ -187,30 +189,33 @@ upsert record updates = do
uniqueKey <- onlyUnique record
upsertBy uniqueKey record updates
upsertBy :: (MonadIO m,
PersistEntity record,
IsPersistBackend (PersistEntityBackend record))
=> Unique record
-- ^ uniqueness constraint to find by
-> record
-- ^ new record to insert
-> [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
::
(MonadIO m
, PersistEntity record
, IsPersistBackend (PersistEntityBackend record)
)
=> Unique record
-- ^ uniqueness constraint to find by
-> record
-- ^ new record to insert
-> [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
sqlB <- R.ask
maybe
(throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent
(handler sqlB)
(connUpsertSql sqlB)
sqlB <- R.ask
maybe
(throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent
(handler sqlB)
(connUpsertSql sqlB)
where
addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey
entDef = entityDef (Just record)
uDef = toUniqueDef uniqueKey
updatesText conn = first builderToText $ renderUpdates conn updates
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
-- 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.
--
-- @since 3.1.3
insertSelectWithConflict :: forall a m val. (
FinalResult a,
KnowResult a ~ (Unique val),
MonadIO m,
PersistEntity val) =>
a
-- ^ 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.
-> SqlQuery (SqlExpr (Insertion val))
-- ^ Insert query.
-> (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.
-> SqlWriteT m ()
insertSelectWithConflict unique query = void . insertSelectWithConflictCount unique query
insertSelectWithConflict
:: forall a m val
. (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
=> a
-- ^ 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.
-> SqlQuery (SqlExpr (Insertion val))
-- ^ Insert query.
-> (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.
-> SqlWriteT m ()
insertSelectWithConflict unique query =
void . insertSelectWithConflictCount unique query
-- | Same as 'insertSelectWithConflict' but returns the number of rows affected.
--
-- @since 3.1.3
insertSelectWithConflictCount :: forall a val m. (
FinalResult a,
KnowResult a ~ (Unique val),
MonadIO m,
PersistEntity val) =>
a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-> SqlWriteT m Int64
insertSelectWithConflictCount
:: forall a val m
. (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
=> a
-> SqlQuery (SqlExpr (Insertion val))
-> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
-> SqlWriteT m Int64
insertSelectWithConflictCount unique query conflictQuery = do
conn <- R.ask
uncurry rawExecuteCount $
combine
(toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))
(conflict conn)
conn <- R.ask
uncurry rawExecuteCount $
combine
(toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))
(conflict conn)
where
proxy :: Proxy val
proxy = Proxy
@ -289,7 +295,7 @@ insertSelectWithConflictCount unique query conflictQuery = do
constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef
renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
renderedUpdates conn = renderUpdates conn updates
conflict conn = (foldr1 mappend ([
conflict conn = (mconcat ([
TLB.fromText "ON CONFLICT ON CONSTRAINT \"",
constraint,
TLB.fromText "\" DO "
@ -327,18 +333,18 @@ insertSelectWithConflictCount unique query conflictQuery = do
--
-- @since 3.3.3.3
filterWhere
:: SqlExpr (Value a)
-- ^ Aggregate function
-> SqlExpr (Value Bool)
-- ^ Filter clause
-> SqlExpr (Value a)
:: SqlExpr (Value a)
-- ^ Aggregate function
-> SqlExpr (Value Bool)
-- ^ Filter clause
-> SqlExpr (Value a)
filterWhere aggExpr clauseExpr = ERaw Never $ \info ->
let (aggBuilder, aggValues) = case aggExpr of
ERaw _ aggF -> aggF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError
(clauseBuilder, clauseValues) = case clauseExpr of
ERaw _ clauseF -> clauseF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError
in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
, aggValues <> clauseValues
)
let (aggBuilder, aggValues) = case aggExpr of
ERaw _ aggF -> aggF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError
(clauseBuilder, clauseValues) = case clauseExpr of
ERaw _ clauseF -> clauseF info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError
in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
, aggValues <> clauseValues
)

215
src/Database/Esqueleto/PostgreSQL/JSON.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-|
This module contains PostgreSQL-specific JSON functions.
@ -22,130 +23,128 @@
@since 3.1.0
-}
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
-- database table models as long as your type has 'FromJSON'
-- and 'ToJSON' instances.
-- | /Better documentation included with individual functions/
--
-- 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|
-- Example
-- json (JSONB MyType)
-- |]
-- | /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) |
-- @
--
-- 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
--
-- | /Better documentation included with individual functions/
--
-- The arrow operators are selection functions to select values
-- 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
-- /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 Database.Esqueleto.Internal.Language hiding ((?.), (-.), (||.))
import Database.Esqueleto.Internal.Language hiding ((-.), (?.), (||.))
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
import Database.Esqueleto.PostgreSQL.JSON.Instances
infixl 6 ->., ->>., #>., #>>.
infixl 6 @>., <@., ?., ?|., ?&.
infixl 6 ||., -., --., #-.
-- | /Requires PostgreSQL version >= 9.3/
--
-- This function extracts the jsonb value from a JSON array or object,

78
src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs
View File

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

6
src/Database/Esqueleto/SQLite.hs
View File

@ -1,14 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
-- | This module contain SQLite-specific functions.
--
-- /Since: 2.2.8/
-- @since 2.2.8
module Database.Esqueleto.SQLite
( random_
) where
import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql
-- | (@random()@) Split out into database specific modules
-- 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.

992
test/Common/Test.hs
View File

File diff suppressed because it is too large Load Diff