{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE CPP #-}
module Database.Beam.Postgres.PgSpecific
(
TsVectorConfig, TsVector(..)
, toTsVector, english
, TsQuery(..), (@@)
, PgJSON(..), PgJSONB(..)
, IsPgJSON(..)
, PgJSONEach(..), PgJSONKey(..), PgJSONElement(..)
, (@>), (<@), (->#), (->$)
, (->>#), (->>$), (#>), (#>>)
, (?), (?|), (?&)
, withoutKey, withoutIdx
, withoutKeys
, pgJsonArrayLength
, pgJsonbUpdate, pgJsonbSet
, pgJsonbPretty
, PgMoney(..), pgMoney
, pgScaleMoney_
, pgDivideMoney_, pgDivideMoneys_
, pgAddMoney_, pgSubtractMoney_
, pgSumMoneyOver_, pgAvgMoneyOver_
, pgSumMoney_, pgAvgMoney_
, PgSetOf, pgUnnest
, pgUnnestArray, pgUnnestArrayWithOrdinality
, PgArrayValueContext, PgIsArrayContext
, array_, arrayOf_, (++.)
, pgArrayAgg, pgArrayAggOver
, (!.), arrayDims_
, arrayUpper_, arrayLower_
, arrayUpperUnsafe_, arrayLowerUnsafe_
, arrayLength_, arrayLengthUnsafe_
, isSupersetOf_, isSubsetOf_
, pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver
, pgNubBy_
, now_, ilike_
)
where
import Database.Beam
import Database.Beam.Backend.SQL
import Database.Beam.Migrate ( HasDefaultSqlDataType(..)
, HasDefaultSqlDataTypeConstraints(..) )
import Database.Beam.Postgres.Syntax
import Database.Beam.Postgres.Types
import Database.Beam.Query.Internal
import Database.Beam.Schema.Tables
import Control.Monad.Free
import Control.Monad.State.Strict (evalState, put, get)
import Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
import Data.Hashable
import Data.Proxy
import Data.Scientific (Scientific, formatScientific, FPFormat(Fixed))
import Data.String
import qualified Data.Text as T
import Data.Time (LocalTime)
import Data.Type.Bool
import qualified Data.Vector as V
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup
#endif
import qualified Database.PostgreSQL.Simple.FromField as Pg
import qualified Database.PostgreSQL.Simple.ToField as Pg
import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg
import GHC.TypeLits
import GHC.Exts hiding (toList)
now_ :: QExpr PgExpressionSyntax s LocalTime
now_ = QExpr (\_ -> PgExpressionSyntax (emit "NOW()"))
ilike_ :: IsSqlExpressionSyntaxStringType PgExpressionSyntax text
=> QExpr PgExpressionSyntax s text
-> QExpr PgExpressionSyntax s text
-> QExpr PgExpressionSyntax s Bool
ilike_ (QExpr a) (QExpr b) = QExpr (pgBinOp "ILIKE" <$> a <*> b)
newtype TsVector = TsVector ByteString
deriving (Show, Eq, Ord)
newtype TsVectorConfig = TsVectorConfig ByteString
deriving (Show, Eq, Ord, IsString)
instance Pg.FromField TsVector where
fromField field d =
if Pg.typeOid field /= Pg.typoid pgTsVectorTypeInfo
then Pg.returnError Pg.Incompatible field ""
else case d of
Just d' -> pure (TsVector d')
Nothing -> Pg.returnError Pg.UnexpectedNull field ""
instance Pg.ToField TsVector where
toField (TsVector d) =
Pg.Many [ Pg.Plain "($$"
, Pg.Plain (byteString d)
, Pg.Plain "$$::tsvector)" ]
instance FromBackendRow Postgres TsVector
instance HasSqlEqualityCheck PgExpressionSyntax TsVectorConfig
instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsVectorConfig
instance HasSqlEqualityCheck PgExpressionSyntax TsVector
instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsVector
english :: TsVectorConfig
english = TsVectorConfig "english"
toTsVector :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str
=> Maybe TsVectorConfig -> QGenExpr context PgExpressionSyntax s str
-> QGenExpr context PgExpressionSyntax s TsVector
toTsVector Nothing (QExpr x) =
QExpr (fmap (\(PgExpressionSyntax x') ->
PgExpressionSyntax $
emit "to_tsquery(" <> x' <> emit ")") x)
toTsVector (Just (TsVectorConfig configNm)) (QExpr x) =
QExpr (fmap (\(PgExpressionSyntax x') -> PgExpressionSyntax $
emit "to_tsquery('" <> escapeString configNm <> emit "', " <> x' <> emit ")") x)
(@@) :: QGenExpr context PgExpressionSyntax s TsVector
-> QGenExpr context PgExpressionSyntax s TsQuery
-> QGenExpr context PgExpressionSyntax s Bool
QExpr vec @@ QExpr q =
QExpr (pgBinOp "@@" <$> vec <*> q)
newtype TsQuery = TsQuery ByteString
deriving (Show, Eq, Ord)
instance HasSqlEqualityCheck PgExpressionSyntax TsQuery
instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax TsQuery
instance Pg.FromField TsQuery where
fromField field d =
if Pg.typeOid field /= Pg.typoid pgTsQueryTypeInfo
then Pg.returnError Pg.Incompatible field ""
else case d of
Just d' -> pure (TsQuery d')
Nothing -> Pg.returnError Pg.UnexpectedNull field ""
instance FromBackendRow Postgres TsQuery
(!.) :: Integral ix
=> QGenExpr context PgExpressionSyntax s (V.Vector a)
-> QGenExpr context PgExpressionSyntax s ix
-> QGenExpr context PgExpressionSyntax s a
QExpr v !. QExpr ix =
QExpr (index <$> v <*> ix)
where
index (PgExpressionSyntax v') (PgExpressionSyntax ix') =
PgExpressionSyntax (emit "(" <> v' <> emit ")[" <> ix' <> emit "]")
arrayDims_ :: IsSqlExpressionSyntaxStringType PgExpressionSyntax text
=> QGenExpr context PgExpressionSyntax s (V.Vector a)
-> QGenExpr context PgExpressionSyntax s text
arrayDims_ (QExpr v) = QExpr (fmap (\(PgExpressionSyntax v') -> PgExpressionSyntax (emit "array_dims(" <> v' <> emit ")")) v)
type family CountDims (v :: *) :: Nat where
CountDims (V.Vector a) = 1 + CountDims a
CountDims a = 0
type family WithinBounds (dim :: Nat) (v :: *) :: Constraint where
WithinBounds dim v =
If ((dim <=? CountDims v) && (1 <=? dim))
(() :: Constraint)
(TypeError ( ('Text "Dimension " ':<>: 'ShowType dim ':<>: 'Text " is out of bounds.") ':$$:
('Text "The type " ':<>: 'ShowType v ':<>: 'Text " has " ':<>: 'ShowType (CountDims v) ':<>: 'Text " dimension(s).") ':$$:
('Text "Hint: The dimension should be a natural between 1 and " ':<>: 'ShowType (CountDims v)) ))
arrayUpper_, arrayLower_
:: forall (dim :: Nat) context num v s.
(KnownNat dim, WithinBounds dim (V.Vector v), Integral num)
=> QGenExpr context PgExpressionSyntax s (V.Vector v)
-> QGenExpr context PgExpressionSyntax s num
arrayUpper_ v =
unsafeRetype (arrayUpperUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context PgExpressionSyntax s (Maybe Integer))
arrayLower_ v =
unsafeRetype (arrayLowerUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr context PgExpressionSyntax s (Maybe Integer))
arrayUpperUnsafe_, arrayLowerUnsafe_
:: (Integral dim, Integral length)
=> QGenExpr context PgExpressionSyntax s (V.Vector v)
-> QGenExpr context PgExpressionSyntax s dim
-> QGenExpr context PgExpressionSyntax s (Maybe length)
arrayUpperUnsafe_ (QExpr v) (QExpr dim) =
QExpr (fmap (PgExpressionSyntax . mconcat) . sequenceA $
[ pure (emit "array_upper(")
, fromPgExpression <$> v
, pure (emit ", ")
, fromPgExpression <$> dim
, pure (emit ")") ])
arrayLowerUnsafe_ (QExpr v) (QExpr dim) =
QExpr (fmap (PgExpressionSyntax . mconcat) . sequenceA $
[ pure (emit "array_lower(")
, fromPgExpression <$> v
, pure (emit ", ")
, fromPgExpression <$> dim
, pure (emit ")") ])
arrayLength_
:: forall (dim :: Nat) ctxt num v s.
(KnownNat dim, WithinBounds dim (V.Vector v), Integral num)
=> QGenExpr ctxt PgExpressionSyntax s (V.Vector v)
-> QGenExpr ctxt PgExpressionSyntax s num
arrayLength_ v =
unsafeRetype (arrayLengthUnsafe_ v (val_ (natVal (Proxy @dim) :: Integer)) :: QGenExpr ctxt PgExpressionSyntax s (Maybe Integer))
arrayLengthUnsafe_
:: (Integral dim, Integral num)
=> QGenExpr ctxt PgExpressionSyntax s (V.Vector v)
-> QGenExpr ctxt PgExpressionSyntax s dim
-> QGenExpr ctxt PgExpressionSyntax s (Maybe num)
arrayLengthUnsafe_ (QExpr a) (QExpr dim) =
QExpr $ fmap (PgExpressionSyntax . mconcat) $ sequenceA $
[ pure (emit "array_length(")
, fromPgExpression <$> a
, pure (emit ", ")
, fromPgExpression <$> dim
, pure (emit ")") ]
isSupersetOf_ :: QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
-> QGenExpr ctxt PgExpressionSyntax s Bool
isSupersetOf_ (QExpr haystack) (QExpr needles) =
QExpr (pgBinOp "@>" <$> haystack <*> needles)
isSubsetOf_ :: QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
-> QGenExpr ctxt PgExpressionSyntax s Bool
isSubsetOf_ (QExpr needles) (QExpr haystack) =
QExpr (pgBinOp "<@" <$> needles <*> haystack)
(++.) :: QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector a)
QExpr a ++. QExpr b =
QExpr (pgBinOp "||" <$> a <*> b)
data PgArrayValueContext
class PgIsArrayContext ctxt where
mkArraySyntax :: Proxy ctxt -> PgSyntax -> PgSyntax
mkArraySyntax _ s = emit "ARRAY" <> s
instance PgIsArrayContext PgArrayValueContext where
mkArraySyntax _ = id
instance PgIsArrayContext QValueContext
instance PgIsArrayContext QAggregateContext
instance PgIsArrayContext QWindowingContext
array_ :: forall context f s a.
(PgIsArrayContext context, Foldable f)
=> f (QGenExpr PgArrayValueContext PgExpressionSyntax s a)
-> QGenExpr context PgExpressionSyntax s (V.Vector a)
array_ vs =
QExpr $ fmap (PgExpressionSyntax . mkArraySyntax (Proxy @context) . mconcat) $
sequenceA [ pure (emit "[")
, pgSepBy (emit ", ") <$> mapM (\(QExpr e) -> fromPgExpression <$> e) (toList vs)
, pure (emit "]") ]
arrayOf_ :: Q PgSelectSyntax db s (QExpr PgExpressionSyntax s a)
-> QGenExpr context PgExpressionSyntax s (V.Vector a)
arrayOf_ q =
let QExpr sub = subquery_ q
in QExpr (\t -> let PgExpressionSyntax sub' = sub t
in PgExpressionSyntax (emit "ARRAY(" <> sub' <> emit ")"))
newtype PgJSON a = PgJSON a
deriving ( Show, Eq, Ord, Hashable, Monoid )
instance HasSqlEqualityCheck PgExpressionSyntax (PgJSON a)
instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSON a)
instance (Typeable x, FromJSON x) => Pg.FromField (PgJSON x) where
fromField field d =
if Pg.typeOid field /= Pg.typoid Pg.json
then Pg.returnError Pg.Incompatible field ""
else case decodeStrict =<< d of
Just d' -> pure (PgJSON d')
Nothing -> Pg.returnError Pg.UnexpectedNull field ""
instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSON a)
instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSON a) where
sqlValueSyntax (PgJSON a) =
PgValueSyntax $
emit "'" <> escapeString (BL.toStrict (encode a)) <> emit "'::json"
newtype PgJSONB a = PgJSONB a
deriving ( Show, Eq, Ord, Hashable, Monoid )
instance HasSqlEqualityCheck PgExpressionSyntax (PgJSONB a)
instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax (PgJSONB a)
instance (Typeable x, FromJSON x) => Pg.FromField (PgJSONB x) where
fromField field d =
if Pg.typeOid field /= Pg.typoid Pg.jsonb
then Pg.returnError Pg.Incompatible field ""
else case decodeStrict =<< d of
Just d' -> pure (PgJSONB d')
Nothing -> Pg.returnError Pg.UnexpectedNull field ""
instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSONB a)
instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSONB a) where
sqlValueSyntax (PgJSONB a) =
PgValueSyntax $
emit "'" <> escapeString (BL.toStrict (encode a)) <> emit "'::jsonb"
data PgJSONEach valType f
= PgJSONEach
{ pgJsonEachKey :: C f T.Text
, pgJsonEachValue :: C f valType
} deriving Generic
instance Beamable (PgJSONEach valType)
data PgJSONKey f = PgJSONKey { pgJsonKey :: C f T.Text }
deriving Generic
instance Beamable PgJSONKey
data PgJSONElement a f = PgJSONElement { pgJsonElement :: C f a }
deriving Generic
instance Beamable (PgJSONElement a)
class IsPgJSON (json :: * -> *) where
pgJsonEach :: QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONEach (json Value)))
pgJsonEachText :: QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONEach T.Text))
pgJsonKeys :: QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (PgSetOf PgJSONKey)
pgJsonArrayElements :: QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONElement (json Value)))
pgJsonArrayElementsText :: QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (PgSetOf (PgJSONElement T.Text))
pgJsonTypeOf :: QGenExpr ctxt PgExpressionSyntax s (json a) -> QGenExpr ctxt PgExpressionSyntax s T.Text
pgJsonStripNulls :: QGenExpr ctxt PgExpressionSyntax s (json a) -> QGenExpr ctxt PgExpressionSyntax s (json b)
pgJsonAgg :: QExpr PgExpressionSyntax s a -> QAgg PgExpressionSyntax s (json a)
pgJsonObjectAgg :: QExpr PgExpressionSyntax s key -> QExpr PgExpressionSyntax s value
-> QAgg PgExpressionSyntax s (json a)
instance IsPgJSON PgJSON where
pgJsonEach (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_each") . pgParens . fromPgExpression) a
pgJsonEachText (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_each_text") . pgParens . fromPgExpression) a
pgJsonKeys (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_object_keys") . pgParens . fromPgExpression) a
pgJsonArrayElements (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_array_elements") . pgParens . fromPgExpression) a
pgJsonArrayElementsText (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_array_elements_text") . pgParens . fromPgExpression) a
pgJsonTypeOf (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_typeof") . pgParens . fromPgExpression) a
pgJsonStripNulls (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_strip_nulls") . pgParens . fromPgExpression) a
pgJsonAgg (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_agg") . pgParens . fromPgExpression) a
pgJsonObjectAgg (QExpr keys) (QExpr values) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "json_object_agg") . pgParens . mconcat) $
sequenceA $ [ fromPgExpression <$> keys, pure (emit ", ")
, fromPgExpression <$> values ]
instance IsPgJSON PgJSONB where
pgJsonEach (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_each") . pgParens . fromPgExpression) a
pgJsonEachText (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_each_text") . pgParens . fromPgExpression) a
pgJsonKeys (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_object_keys") . pgParens . fromPgExpression) a
pgJsonArrayElements (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_array_elements") . pgParens . fromPgExpression) a
pgJsonArrayElementsText (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_array_elements_text") . pgParens . fromPgExpression) a
pgJsonTypeOf (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_typeof") . pgParens . fromPgExpression) a
pgJsonStripNulls (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_strip_nulls") . pgParens . fromPgExpression) a
pgJsonAgg (QExpr a) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_agg") . pgParens . fromPgExpression) a
pgJsonObjectAgg (QExpr keys) (QExpr values) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_object_agg") . pgParens . mconcat) $
sequenceA $ [ fromPgExpression <$> keys, pure (emit ", ")
, fromPgExpression <$> values ]
(@>), (<@) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (json b)
-> QGenExpr ctxt PgExpressionSyntax s Bool
QExpr a @> QExpr b =
QExpr (pgBinOp "@>" <$> a <*> b)
QExpr a <@ QExpr b =
QExpr (pgBinOp "<@" <$> a <*> b)
(->#) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s Int
-> QGenExpr ctxt PgExpressionSyntax s (json b)
QExpr a -># QExpr b =
QExpr (pgBinOp "->" <$> a <*> b)
(->$) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s T.Text
-> QGenExpr ctxt PgExpressionSyntax s (json b)
QExpr a ->$ QExpr b =
QExpr (pgBinOp "->" <$> a <*> b)
(->>#) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s Int
-> QGenExpr ctxt PgExpressionSyntax s T.Text
QExpr a ->># QExpr b =
QExpr (pgBinOp "->>" <$> a <*> b)
(->>$) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s T.Text
-> QGenExpr ctxt PgExpressionSyntax s T.Text
QExpr a ->>$ QExpr b =
QExpr (pgBinOp "->>" <$> a <*> b)
(#>) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)
-> QGenExpr ctxt PgExpressionSyntax s (json b)
QExpr a #> QExpr b =
QExpr (pgBinOp "#>" <$> a <*> b)
(#>>) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)
-> QGenExpr ctxt PgExpressionSyntax s T.Text
QExpr a #>> QExpr b =
QExpr (pgBinOp "#>>" <$> a <*> b)
(?) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s T.Text
-> QGenExpr ctxt PgExpressionSyntax s Bool
QExpr a ? QExpr b =
QExpr (pgBinOp "?" <$> a <*> b)
(?|), (?&) :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)
-> QGenExpr ctxt PgExpressionSyntax s Bool
QExpr a ?| QExpr b =
QExpr (pgBinOp "?|" <$> a <*> b)
QExpr a ?& QExpr b =
QExpr (pgBinOp "?&" <$> a <*> b)
withoutKey :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s T.Text
-> QGenExpr ctxt PgExpressionSyntax s (json b)
QExpr a `withoutKey` QExpr b =
QExpr (pgBinOp "-" <$> a <*> b)
withoutIdx :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s Int
-> QGenExpr ctxt PgExpressionSyntax s (json b)
QExpr a `withoutIdx` QExpr b =
QExpr (pgBinOp "-" <$> a <*> b)
withoutKeys :: IsPgJSON json
=> QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)
-> QGenExpr ctxt PgExpressionSyntax s (json b)
QExpr a `withoutKeys` QExpr b =
QExpr (pgBinOp "#-" <$> a <*> b)
pgJsonArrayLength :: IsPgJSON json => QGenExpr ctxt PgExpressionSyntax s (json a)
-> QGenExpr ctxt PgExpressionSyntax s Int
pgJsonArrayLength (QExpr a) =
QExpr $ \tbl ->
PgExpressionSyntax (emit "json_array_length(" <> fromPgExpression (a tbl) <> emit ")")
pgJsonbUpdate, pgJsonbSet
:: QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)
-> QGenExpr ctxt PgExpressionSyntax s (V.Vector T.Text)
-> QGenExpr ctxt PgExpressionSyntax s (PgJSONB b)
-> QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)
pgJsonbUpdate (QExpr a) (QExpr path) (QExpr newVal) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_set") . pgParens . mconcat) $ sequenceA $
[ fromPgExpression <$> a, pure (emit ", "), fromPgExpression <$> path, pure (emit ", "), fromPgExpression <$> newVal ]
pgJsonbSet (QExpr a) (QExpr path) (QExpr newVal) =
QExpr $ fmap (PgExpressionSyntax . mappend (emit "jsonb_set") . pgParens . mconcat) $ sequenceA $
[ fromPgExpression <$> a, pure (emit ", "), fromPgExpression <$> path, pure (emit ", "), fromPgExpression <$> newVal, pure (emit ", true") ]
pgJsonbPretty :: QGenExpr ctxt PgExpressionSyntax s (PgJSONB a)
-> QGenExpr ctxt PgExpressionSyntax s T.Text
pgJsonbPretty (QExpr a) =
QExpr (\tbl -> PgExpressionSyntax (emit "jsonb_pretty" <> pgParens (fromPgExpression (a tbl))))
pgArrayAgg :: QExpr PgExpressionSyntax s a
-> QAgg PgExpressionSyntax s (V.Vector a)
pgArrayAgg = pgArrayAggOver allInGroup_
pgArrayAggOver :: Maybe PgAggregationSetQuantifierSyntax
-> QExpr PgExpressionSyntax s a
-> QAgg PgExpressionSyntax s (V.Vector a)
pgArrayAggOver quantifier (QExpr a) =
QExpr $ \tbl ->
PgExpressionSyntax $
emit "array_agg" <>
pgParens ( maybe mempty (\q -> fromPgAggregationSetQuantifier q <> emit " ") quantifier <>
fromPgExpression (a tbl))
pgBoolOr :: QExpr PgExpressionSyntax s a
-> QAgg PgExpressionSyntax s (Maybe Bool)
pgBoolOr (QExpr a) =
QExpr $ \tbl -> PgExpressionSyntax $
emit "bool_or" <> pgParens (fromPgExpression (a tbl))
pgBoolAnd :: QExpr PgExpressionSyntax s a
-> QAgg PgExpressionSyntax s (Maybe Bool)
pgBoolAnd (QExpr a) =
QExpr $ \tbl -> PgExpressionSyntax $
emit "bool_and" <> pgParens (fromPgExpression (a tbl))
pgStringAgg :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str
=> QExpr PgExpressionSyntax s str
-> QExpr PgExpressionSyntax s str
-> QAgg PgExpressionSyntax s (Maybe str)
pgStringAgg = pgStringAggOver allInGroup_
pgStringAggOver :: IsSqlExpressionSyntaxStringType PgExpressionSyntax str
=> Maybe PgAggregationSetQuantifierSyntax
-> QExpr PgExpressionSyntax s str
-> QExpr PgExpressionSyntax s str
-> QAgg PgExpressionSyntax s (Maybe str)
pgStringAggOver quantifier (QExpr v) (QExpr delim) =
QExpr $ \tbl -> PgExpressionSyntax $
emit "string_agg" <>
pgParens ( maybe mempty (\q -> fromPgAggregationSetQuantifier q <> emit " ") quantifier <>
fromPgExpression (v tbl) <> emit ", " <>
fromPgExpression (delim tbl))
pgNubBy_ :: ( Projectible PgExpressionSyntax key
, Projectible PgExpressionSyntax r )
=> (r -> key)
-> Q PgSelectSyntax db s r
-> Q PgSelectSyntax db s r
pgNubBy_ mkKey (Q q) = Q $ liftF (QDistinct (\r pfx -> pgSelectSetQuantifierDistinctOn (project (mkKey r) pfx)) q id)
newtype PgMoney = PgMoney { fromPgMoney :: ByteString }
deriving (Show, Read, Eq, Ord)
instance Pg.FromField PgMoney where
fromField field Nothing = Pg.returnError Pg.UnexpectedNull field ""
fromField field (Just d) =
if Pg.typeOid field /= Pg.typoid Pg.money
then Pg.returnError Pg.Incompatible field ""
else pure (PgMoney d)
instance Pg.ToField PgMoney where
toField (PgMoney a) = Pg.toField a
instance HasSqlEqualityCheck PgExpressionSyntax PgMoney
instance HasSqlQuantifiedEqualityCheck PgExpressionSyntax PgMoney
instance FromBackendRow Postgres PgMoney
instance HasSqlValueSyntax PgValueSyntax PgMoney where
sqlValueSyntax (PgMoney a) = sqlValueSyntax a
pgMoney :: Real a => a -> PgMoney
pgMoney val = PgMoney (BC.pack (formatScientific Fixed Nothing exactVal))
where
exactVal = fromRational (toRational val) :: Scientific
pgScaleMoney_ :: Num a
=> QGenExpr context PgExpressionSyntax s a
-> QGenExpr context PgExpressionSyntax s PgMoney
-> QGenExpr context PgExpressionSyntax s PgMoney
pgScaleMoney_ (QExpr scale) (QExpr v) =
QExpr (pgBinOp "*" <$> scale <*> v)
pgDivideMoney_ :: Num a
=> QGenExpr context PgExpressionSyntax s PgMoney
-> QGenExpr context PgExpressionSyntax s a
-> QGenExpr context PgExpressionSyntax s PgMoney
pgDivideMoney_ (QExpr v) (QExpr scale) =
QExpr (pgBinOp "/" <$> v <*> scale)
pgDivideMoneys_ :: Num a
=> QGenExpr context PgExpressionSyntax s PgMoney
-> QGenExpr context PgExpressionSyntax s PgMoney
-> QGenExpr context PgExpressionSyntax s a
pgDivideMoneys_ (QExpr a) (QExpr b) =
QExpr (pgBinOp "/" <$> a <*> b)
pgAddMoney_, pgSubtractMoney_
:: QGenExpr context PgExpressionSyntax s PgMoney
-> QGenExpr context PgExpressionSyntax s PgMoney
-> QGenExpr context PgExpressionSyntax s PgMoney
pgAddMoney_ (QExpr a) (QExpr b) =
QExpr (pgBinOp "+" <$> a <*> b)
pgSubtractMoney_ (QExpr a) (QExpr b) =
QExpr (pgBinOp "-" <$> a <*> b)
pgSumMoneyOver_, pgAvgMoneyOver_
:: Maybe PgAggregationSetQuantifierSyntax
-> QExpr PgExpressionSyntax s PgMoney -> QExpr PgExpressionSyntax s PgMoney
pgSumMoneyOver_ q (QExpr a) = QExpr (sumE q <$> a)
pgAvgMoneyOver_ q (QExpr a) = QExpr (avgE q <$> a)
pgSumMoney_, pgAvgMoney_ :: QExpr PgExpressionSyntax s PgMoney
-> QExpr PgExpressionSyntax s PgMoney
pgSumMoney_ = pgSumMoneyOver_ allInGroup_
pgAvgMoney_ = pgAvgMoneyOver_ allInGroup_
data PgSetOf (tbl :: (* -> *) -> *)
pgUnnest' :: forall tbl db s
. Beamable tbl
=> (TablePrefix -> PgSyntax)
-> Q PgSelectSyntax db s (QExprTable PgExpressionSyntax s tbl)
pgUnnest' q =
Q (liftF (QAll (\pfx alias ->
PgFromSyntax . mconcat $
[ q pfx, emit " "
, pgQuotedIdentifier alias
, pgParens (pgSepBy (emit ", ") (allBeamValues (\(Columnar' (TableField nm)) -> pgQuotedIdentifier nm) tblFields))
])
tblFields
(\_ -> Nothing) snd))
where
tblFields :: TableSettings tbl
tblFields =
evalState (zipBeamFieldsM (\_ _ ->
do i <- get
put (i + 1)
pure (Columnar' (TableField (fromString ("r" ++ show i)))))
tblSkeleton tblSkeleton) (0 :: Int)
pgUnnest :: forall tbl db s
. Beamable tbl
=> QExpr PgExpressionSyntax s (PgSetOf tbl)
-> Q PgSelectSyntax db s (QExprTable PgExpressionSyntax s tbl)
pgUnnest (QExpr q) =
pgUnnest' (\t -> pgParens (fromPgExpression (q t)))
data PgUnnestArrayTbl a f = PgUnnestArrayTbl (C f a)
deriving Generic
instance Beamable (PgUnnestArrayTbl a)
pgUnnestArray :: QExpr PgExpressionSyntax s (V.Vector a)
-> Q PgSelectSyntax db s (QExpr PgExpressionSyntax s a)
pgUnnestArray (QExpr q) =
fmap (\(PgUnnestArrayTbl x) -> x) $
pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)))
data PgUnnestArrayWithOrdinalityTbl a f = PgUnnestArrayWithOrdinalityTbl (C f Int) (C f a)
deriving Generic
instance Beamable (PgUnnestArrayWithOrdinalityTbl a)
pgUnnestArrayWithOrdinality :: QExpr PgExpressionSyntax s (V.Vector a)
-> Q PgSelectSyntax db s (QExpr PgExpressionSyntax s Int, QExpr PgExpressionSyntax s a)
pgUnnestArrayWithOrdinality (QExpr q) =
fmap (\(PgUnnestArrayWithOrdinalityTbl i x) -> (i, x)) $
pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)) <> emit " WITH ORDINALITY")
instance HasDefaultSqlDataType PgDataTypeSyntax TsQuery where
defaultSqlDataType _ _ = pgTsQueryType
instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax TsQuery
instance HasDefaultSqlDataType PgDataTypeSyntax TsVector where
defaultSqlDataType _ _ = pgTsVectorType
instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax TsVector
instance HasDefaultSqlDataType PgDataTypeSyntax (PgJSON a) where
defaultSqlDataType _ _ = pgJsonType
instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (PgJSON a)
instance HasDefaultSqlDataType PgDataTypeSyntax (PgJSONB a) where
defaultSqlDataType _ _ = pgJsonbType
instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (PgJSONB a)
instance HasDefaultSqlDataType PgDataTypeSyntax PgMoney where
defaultSqlDataType _ _ = pgMoneyType
instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax PgMoney
instance HasDefaultSqlDataType PgDataTypeSyntax a => HasDefaultSqlDataType PgDataTypeSyntax (V.Vector a) where
defaultSqlDataType _ embedded = pgUnboundedArrayType (defaultSqlDataType (Proxy :: Proxy a) embedded)
instance HasDefaultSqlDataTypeConstraints PgColumnSchemaSyntax (V.Vector a)