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

major formatting stuff

Browse Source
This commit is contained in:
parsonsmatt 2020-10-28 23:04:02 -06:00
parent 58575433ff
commit ea032a9fc5
10 changed files with 2617 additions and 2304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

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

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

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

@ -1,10 +1,11 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-- | This module contain MySQL-specific functions. -- | This module contain MySQL-specific functions.
-- --
-- /Since: 2.2.8/ -- @since 2.2.8
module Database.Esqueleto.MySQL module Database.Esqueleto.MySQL
( random_ ( random_
) where ) where
import Database.Esqueleto.Internal.Language hiding (random_) import Database.Esqueleto.Internal.Language hiding (random_)
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport

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

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

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

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

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

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