major formatting stuff
This commit is contained in:
parsonsmatt
parent
58575433ff
commit
ea032a9fc5
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
@ -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
|
||||
, (!=.)
|
||||
, (*=.)
|
||||
, (+=.)
|
||||
, (-=.)
|
||||
, (/<-.)
|
||||
, (/=.)
|
||||
, (<-.)
|
||||
, (<.)
|
||||
, (<=.)
|
||||
, (=.)
|
||||
, (==.)
|
||||
, (>.)
|
||||
, (>=.)
|
||||
, (||.)
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -1,10 +1,11 @@
|
||||
{-# 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.PersistentImport
|
||||
|
||||
@ -1,59 +1,70 @@
|
||||
{-# 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
|
||||
( CompositeKeyError(..)
|
||||
, EsqueletoError(..)
|
||||
, FinalResult(..)
|
||||
, Ident(..)
|
||||
, KnowResult
|
||||
, SetClause
|
||||
, UnexpectedCaseError(..)
|
||||
, UnexpectedValueError(..)
|
||||
, renderUpdates
|
||||
, toUniqueDef
|
||||
, uncommas
|
||||
)
|
||||
import Database.Esqueleto.Internal.Language hiding (random_)
|
||||
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
|
||||
import Database.Esqueleto.Internal.Sql
|
||||
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 +80,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 +132,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 +167,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 +178,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 +203,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 +264,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 +309,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 +347,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
|
||||
)
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user