@@ -46,50 +46,7 @@ module Squeal.PostgreSQL.Expression
4646 , FunctionN
4747 , unsafeFunctionN
4848 , Literal (..)
49− , HasParameter (parameter)
50− , param
5149 , PGSubset (..)
52− -- * Types
53− , TypeExpression (..)
54− , cast
55− , PGTyped (..)
56− , typedef
57− , typetable
58− , typeview
59− , bool
60− , int2
61− , smallint
62− , int4
63− , int
64− , integer
65− , int8
66− , bigint
67− , numeric
68− , float4
69− , real
70− , float8
71− , doublePrecision
72− , money
73− , text
74− , char
75− , character
76− , varchar
77− , characterVarying
78− , bytea
79− , timestamp
80− , timestampWithTimeZone
81− , date
82− , time
83− , timeWithTimeZone
84− , interval
85− , uuid
86− , inet
87− , json
88− , jsonb
89− , vararray
90− , fixarray
91− , tsvector
92− , tsquery
9350 -- * Re-export
9451 , (&)
9552 , K (..)
@@ -112,12 +69,10 @@ import GHC.TypeLits
11269import Numeric
11370import Prelude hiding (id, (.))
11471
115−import qualified Data.ByteString as ByteString
11672import qualified Data.Text as Text
11773import qualified Data.Text.Lazy as Lazy (Text)
11874import qualified Data.Text.Lazy as Lazy.Text
11975import qualified GHC.Generics as GHC
120−import qualified Generics.SOP as SOP
12176
12277import Squeal.PostgreSQL.Alias
12378import Squeal.PostgreSQL.Binary
@@ -236,46 +191,6 @@ unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
236191unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
237192 (commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
238193
239−{- | A `HasParameter` constraint is used to indicate a value that is
240−supplied externally to a SQL statement.
241−`Squeal.PostgreSQL.PQ.manipulateParams`,
242−`Squeal.PostgreSQL.PQ.queryParams` and
243−`Squeal.PostgreSQL.PQ.traversePrepared` support specifying data values
244−separately from the SQL command string, in which case `param`s are used to
245−refer to the out-of-line data values.
246−-}
247−class KnownNat n => HasParameter
248− (n :: Nat)
249− (params :: [NullityType])
250− (ty :: NullityType)
251− | n params -> ty where
252− -- | `parameter` takes a `Nat` using type application and a `TypeExpression`.
253− --
254− -- >>> let expr = parameter @1 int4 :: Expression outer '[] grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
255− -- >>> printSQL expr
256− -- ($1 :: int4)
257− parameter
258− :: TypeExpression schemas ty
259− -> Expression outer commons grp schemas params from ty
260− parameter ty = UnsafeExpression $ parenthesized $
261− "$" <> renderNat @n <+> "::"
262− <+> renderSQL ty
263−instance {-# OVERLAPPING #-} HasParameter 1 (ty1:tys) ty1
264−instance {-# OVERLAPPABLE #-} (KnownNat n, HasParameter (n-1) params ty)
265− => HasParameter n (ty' : params) ty
266−
267−-- | `param` takes a `Nat` using type application and for basic types,
268−-- infers a `TypeExpression`.
269−--
270−-- >>> let expr = param @1 :: Expression outer commons grp schemas '[ 'Null 'PGint4] from ('Null 'PGint4)
271−-- >>> printSQL expr
272−-- ($1 :: int4)
273−param
274− :: forall n outer commons schemas params from grp ty
275− . (PGTyped schemas ty, HasParameter n params ty)
276− => Expression outer commons grp schemas params from ty -- ^ param
277−param = parameter @n (pgtype @schemas)
278−
279194instance (HasUnique tab (Join outer from) row, Has col row ty)
280195 => IsLabel col (Expression outer commons 'Ungrouped schemas params from ty) where
281196 fromLabel = UnsafeExpression $ renderSQL (Alias @col)
@@ -457,36 +372,17 @@ instance PGSubset 'PGjsonb
457372instance PGSubset 'PGtsquery
458373instance PGSubset ('PGvararray ty)
459374
460−-- When a `cast` is applied to an `Expression` of a known type, it
461−-- represents a run-time type conversion. The cast will succeed only if a
462−-- suitable type conversion operation has been defined.
463−--
464−-- | >>> printSQL $ true & cast int4
465−-- (TRUE :: int4)
466−cast
467− :: TypeExpression schemas ty1
468− -- ^ type to cast as
469− -> Expression outer commons grp schemas params from ty0
470− -- ^ value to convert
471− -> Expression outer commons grp schemas params from ty1
472−cast ty x = UnsafeExpression $ parenthesized $
473− renderSQL x <+> "::" <+> renderSQL ty
474−
475−{-----------------------------------------
476−text
477−-----------------------------------------}
478−
479375instance IsString
480376 (Expression outer commons grp schemas params from (null 'PGtext)) where
481377 fromString str = UnsafeExpression $
482378 "E\'" <> fromString (escape =<< str) <> "\'"
483379instance IsString
484380 (Expression outer commons grp schemas params from (null 'PGtsvector)) where
485− fromString str = cast tsvector . UnsafeExpression $
381+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsvector") $
486382 "E\'" <> fromString (escape =<< str) <> "\'"
487383instance IsString
488384 (Expression outer commons grp schemas params from (null 'PGtsquery)) where
489− fromString str = cast tsquery . UnsafeExpression $
385+ fromString str = UnsafeExpression . parenthesized . (<> " :: tsquery") $
490386 "E\'" <> fromString (escape =<< str) <> "\'"
491387
492388instance Semigroup
@@ -511,192 +407,13 @@ instance Monoid
511407 mempty = fromString ""
512408 mappend = (<>)
513409
514−{-----------------------------------------
515−type expressions
516−-----------------------------------------}
517−
518−-- | `TypeExpression`s are used in `cast`s and
519−-- `Squeal.PostgreSQL.Definition.createTable` commands.
520−newtype TypeExpression (schemas :: SchemasType) (ty :: NullityType)
521− = UnsafeTypeExpression { renderTypeExpression :: ByteString }
522− deriving (GHC.Generic,Show,Eq,Ord,NFData)
523−instance RenderSQL (TypeExpression schemas ty) where
524− renderSQL = renderTypeExpression
525−
526−-- | The enum or composite type in a `Typedef` can be expressed by its alias.
527−typedef
528− :: (Has sch schemas schema, Has td schema ('Typedef ty))
529− => QualifiedAlias sch td
530− -> TypeExpression schemas (null ty)
531−typedef = UnsafeTypeExpression . renderSQL
532−
533−-- | The composite type corresponding to a `Table` definition can be expressed
534−-- by its alias.
535−typetable
536− :: (Has sch schemas schema, Has tab schema ('Table table))
537− => QualifiedAlias sch tab
538− -> TypeExpression schemas (null ('PGcomposite (TableToRow table)))
539−typetable = UnsafeTypeExpression . renderSQL
540−
541−-- | The composite type corresponding to a `View` definition can be expressed
542−-- by its alias.
543−typeview
544− :: (Has sch schemas schema, Has vw schema ('View view))
545− => QualifiedAlias sch vw
546− -> TypeExpression schemas (null ('PGcomposite view))
547−typeview = UnsafeTypeExpression . renderSQL
548−
549−-- | logical Boolean (true/false)
550−bool :: TypeExpression schemas (null 'PGbool)
551−bool = UnsafeTypeExpression "bool"
552−-- | signed two-byte integer
553−int2, smallint :: TypeExpression schemas (null 'PGint2)
554−int2 = UnsafeTypeExpression "int2"
555−smallint = UnsafeTypeExpression "smallint"
556−-- | signed four-byte integer
557−int4, int, integer :: TypeExpression schemas (null 'PGint4)
558−int4 = UnsafeTypeExpression "int4"
559−int = UnsafeTypeExpression "int"
560−integer = UnsafeTypeExpression "integer"
561−-- | signed eight-byte integer
562−int8, bigint :: TypeExpression schemas (null 'PGint8)
563−int8 = UnsafeTypeExpression "int8"
564−bigint = UnsafeTypeExpression "bigint"
565−-- | arbitrary precision numeric type
566−numeric :: TypeExpression schemas (null 'PGnumeric)
567−numeric = UnsafeTypeExpression "numeric"
568−-- | single precision floating-point number (4 bytes)
569−float4, real :: TypeExpression schemas (null 'PGfloat4)
570−float4 = UnsafeTypeExpression "float4"
571−real = UnsafeTypeExpression "real"
572−-- | double precision floating-point number (8 bytes)
573−float8, doublePrecision :: TypeExpression schemas (null 'PGfloat8)
574−float8 = UnsafeTypeExpression "float8"
575−doublePrecision = UnsafeTypeExpression "double precision"
576−-- | currency amount
577−money :: TypeExpression schema (null 'PGmoney)
578−money = UnsafeTypeExpression "money"
579−-- | variable-length character string
580−text :: TypeExpression schemas (null 'PGtext)
581−text = UnsafeTypeExpression "text"
582−-- | fixed-length character string
583−char, character
584− :: forall n schemas null. (KnownNat n, 1 <= n)
585− => TypeExpression schemas (null ('PGchar n))
586−char = UnsafeTypeExpression $ "char(" <> renderNat @n <> ")"
587−character = UnsafeTypeExpression $ "character(" <> renderNat @n <> ")"
588−-- | variable-length character string
589−varchar, characterVarying
590− :: forall n schemas null. (KnownNat n, 1 <= n)
591− => TypeExpression schemas (null ('PGvarchar n))
592−varchar = UnsafeTypeExpression $ "varchar(" <> renderNat @n <> ")"
593−characterVarying = UnsafeTypeExpression $
594− "character varying(" <> renderNat @n <> ")"
595−-- | binary data ("byte array")
596−bytea :: TypeExpression schemas (null 'PGbytea)
597−bytea = UnsafeTypeExpression "bytea"
598−-- | date and time (no time zone)
599−timestamp :: TypeExpression schemas (null 'PGtimestamp)
600−timestamp = UnsafeTypeExpression "timestamp"
601−-- | date and time, including time zone
602−timestampWithTimeZone :: TypeExpression schemas (null 'PGtimestamptz)
603−timestampWithTimeZone = UnsafeTypeExpression "timestamp with time zone"
604−-- | calendar date (year, month, day)
605−date :: TypeExpression schemas (null 'PGdate)
606−date = UnsafeTypeExpression "date"
607−-- | time of day (no time zone)
608−time :: TypeExpression schemas (null 'PGtime)
609−time = UnsafeTypeExpression "time"
610−-- | time of day, including time zone
611−timeWithTimeZone :: TypeExpression schemas (null 'PGtimetz)
612−timeWithTimeZone = UnsafeTypeExpression "time with time zone"
613−-- | time span
614−interval :: TypeExpression schemas (null 'PGinterval)
615−interval = UnsafeTypeExpression "interval"
616−-- | universally unique identifier
617−uuid :: TypeExpression schemas (null 'PGuuid)
618−uuid = UnsafeTypeExpression "uuid"
619−-- | IPv4 or IPv6 host address
620−inet :: TypeExpression schemas (null 'PGinet)
621−inet = UnsafeTypeExpression "inet"
622−-- | textual JSON data
623−json :: TypeExpression schemas (null 'PGjson)
624−json = UnsafeTypeExpression "json"
625−-- | binary JSON data, decomposed
626−jsonb :: TypeExpression schemas (null 'PGjsonb)
627−jsonb = UnsafeTypeExpression "jsonb"
628−-- | variable length array
629−vararray
630− :: TypeExpression schemas pg
631− -> TypeExpression schemas (null ('PGvararray pg))
632−vararray ty = UnsafeTypeExpression $ renderSQL ty <> "[]"
633−-- | fixed length array
634−--
635−-- >>> renderSQL (fixarray @'[2] json)
636−-- "json[2]"
637−fixarray
638− :: forall dims schemas null pg. SOP.All KnownNat dims
639− => TypeExpression schemas pg
640− -> TypeExpression schemas (null ('PGfixarray dims pg))
641−fixarray ty = UnsafeTypeExpression $
642− renderSQL ty <> renderDims @dims
643− where
644− renderDims :: forall ns. SOP.All KnownNat ns => ByteString
645− renderDims =
646− ("[" <>)
647− . (<> "]")
648− . ByteString.intercalate "]["
649− . hcollapse
650− $ hcmap (SOP.Proxy @KnownNat)
651− (K . fromString . show . natVal)
652− (hpure SOP.Proxy :: NP SOP.Proxy ns)
653−tsvector :: TypeExpression schemas (null 'PGtsvector)
654−tsvector = UnsafeTypeExpression "tsvector"
655−tsquery :: TypeExpression schemas (null 'PGtsquery)
656−tsquery = UnsafeTypeExpression "tsquery"
657−
658−-- | `pgtype` is a demoted version of a `PGType`
659−class PGTyped schemas (ty :: NullityType) where
660− pgtype :: TypeExpression schemas ty
661−instance PGTyped schemas (null 'PGbool) where pgtype = bool
662−instance PGTyped schemas (null 'PGint2) where pgtype = int2
663−instance PGTyped schemas (null 'PGint4) where pgtype = int4
664−instance PGTyped schemas (null 'PGint8) where pgtype = int8
665−instance PGTyped schemas (null 'PGnumeric) where pgtype = numeric
666−instance PGTyped schemas (null 'PGfloat4) where pgtype = float4
667−instance PGTyped schemas (null 'PGfloat8) where pgtype = float8
668−instance PGTyped schemas (null 'PGmoney) where pgtype = money
669−instance PGTyped schemas (null 'PGtext) where pgtype = text
670−instance (KnownNat n, 1 <= n)
671− => PGTyped schemas (null ('PGchar n)) where pgtype = char @n
672−instance (KnownNat n, 1 <= n)
673− => PGTyped schemas (null ('PGvarchar n)) where pgtype = varchar @n
674−instance PGTyped schemas (null 'PGbytea) where pgtype = bytea
675−instance PGTyped schemas (null 'PGtimestamp) where pgtype = timestamp
676−instance PGTyped schemas (null 'PGtimestamptz) where pgtype = timestampWithTimeZone
677−instance PGTyped schemas (null 'PGdate) where pgtype = date
678−instance PGTyped schemas (null 'PGtime) where pgtype = time
679−instance PGTyped schemas (null 'PGtimetz) where pgtype = timeWithTimeZone
680−instance PGTyped schemas (null 'PGinterval) where pgtype = interval
681−instance PGTyped schemas (null 'PGuuid) where pgtype = uuid
682−instance PGTyped schemas (null 'PGjson) where pgtype = json
683−instance PGTyped schemas (null 'PGjsonb) where pgtype = jsonb
684−instance PGTyped schemas ty
685− => PGTyped schemas (null ('PGvararray ty)) where
686− pgtype = vararray (pgtype @schemas @ty)
687−instance (SOP.All KnownNat dims, PGTyped schemas ty)
688− => PGTyped schemas (null ('PGfixarray dims ty)) where
689− pgtype = fixarray @dims (pgtype @schemas @ty)
690−instance PGTyped schemas (null 'PGtsvector) where pgtype = tsvector
691−instance PGTyped schemas (null 'PGtsquery) where pgtype = tsquery
692−
693410class Literal hask where
694411 literal :: hask -> Expr (null (PG hask))
695412instance JSON.ToJSON hask => Literal (Json hask) where
696− literal = cast json . UnsafeExpression
413+ literal = UnsafeExpression . parenthesized . (<> " :: json")
697414 . singleQuotedUtf8 . toStrict . JSON.encode . getJson
698415instance JSON.ToJSON hask => Literal (Jsonb hask) where
699− literal = cast jsonb . UnsafeExpression
416+ literal = UnsafeExpression . parenthesized . (<> " :: jsonb")
700417 . singleQuotedUtf8 . toStrict . JSON.encode . getJsonb
701418instance Literal Char where
702419 literal chr = UnsafeExpression $