{-# LANGUAGE
AllowAmbiguousTypes
, ConstraintKinds
, DeriveGeneric
, DerivingStrategies
, FlexibleContexts
, FlexibleInstances
, FunctionalDependencies
, GADTs
, GeneralizedNewtypeDeriving
, LambdaCase
, MagicHash
, OverloadedStrings
, ScopedTypeVariables
, StandaloneDeriving
, TypeApplications
, TypeFamilies
, TypeInType
, TypeOperators
, UndecidableInstances
, RankNTypes
#-}
module Squeal.PostgreSQL.Expression
(
Expression (..)
, Expr
, type (-->)
, Fun
, unsafeFunction
, function
, unsafeLeftOp
, unsafeRightOp
, Operator
, OperatorDB
, unsafeBinaryOp
, PGSubset (..)
, PGIntersect (..)
, FunctionVar
, unsafeFunctionVar
, type (--->)
, FunN
, unsafeFunctionN
, functionN
, (&)
) where
import Control.Category
import Control.DeepSeq
import Data.Binary.Builder (toLazyByteString)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (doubleDec, floatDec, int16Dec, int32Dec, int64Dec)
import Data.ByteString.Builder.Scientific (scientificBuilder)
import Data.ByteString.Lazy (toStrict)
import Data.Function ((&))
import Data.Semigroup hiding (All)
import Data.String
import Generics.SOP hiding (All, from)
import GHC.OverloadedLabels
import GHC.TypeLits
import Numeric
import Prelude hiding (id, (.))
import qualified GHC.Generics as GHC
import Squeal.PostgreSQL.Type.Alias
import Squeal.PostgreSQL.Type.List
import Squeal.PostgreSQL.Render
import Squeal.PostgreSQL.Type.Schema
newtype Expression
(grp :: Grouping)
(lat :: FromType)
(with :: FromType)
(db :: SchemasType)
(params :: [NullType])
(from :: FromType)
(ty :: NullType)
= UnsafeExpression { renderExpression :: ByteString }
deriving stock (GHC.Generic,Show,Eq,Ord)
deriving newtype (NFData)
instance RenderSQL (Expression grp lat with db params from ty) where
renderSQL = renderExpression
type Expr x
= forall grp lat with db params from
. Expression grp lat with db params from x
type Operator x1 x2 y
= forall grp lat with db params from
. Expression grp lat with db params from x1
-> Expression grp lat with db params from x2
-> Expression grp lat with db params from y
type OperatorDB db x1 x2 y
= forall grp lat with params from
. Expression grp lat with db params from x1
-> Expression grp lat with db params from x2
-> Expression grp lat with db params from y
type (-->) x y = forall db. Fun db x y
type Fun db x y
= forall grp lat with params from
. Expression grp lat with db params from x
-> Expression grp lat with db params from y
type (--->) xs y = forall db. FunN db xs y
type FunN db xs y
= forall grp lat with params from
. NP (Expression grp lat with db params from) xs
-> Expression grp lat with db params from y
type FunctionVar x0 x1 y
= forall grp lat with db params from
. [Expression grp lat with db params from x0]
-> Expression grp lat with db params from x1
-> Expression grp lat with db params from y
unsafeFunctionVar :: ByteString -> FunctionVar x0 x1 y
unsafeFunctionVar fun xs x = UnsafeExpression $ fun <> parenthesized
(commaSeparated (renderSQL <$> xs) <> ", " <> renderSQL x)
instance (HasUnique tab (Join lat from) row, Has col row ty)
=> IsLabel col (Expression 'Ungrouped lat with db params from ty) where
fromLabel = UnsafeExpression $ renderSQL (Alias @col)
instance (HasUnique tab (Join lat from) row, Has col row ty, tys ~ '[ty])
=> IsLabel col (NP (Expression 'Ungrouped lat with db params from) tys) where
fromLabel = fromLabel @col :* Nil
instance (HasUnique tab (Join lat from) row, Has col row ty, column ~ (col ::: ty))
=> IsLabel col
(Aliased (Expression 'Ungrouped lat with db params from) column) where
fromLabel = fromLabel @col `As` Alias
instance (HasUnique tab (Join lat from) row, Has col row ty, columns ~ '[col ::: ty])
=> IsLabel col
(NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where
fromLabel = fromLabel @col :* Nil
instance (Has tab (Join lat from) row, Has col row ty)
=> IsQualified tab col (Expression 'Ungrouped lat with db params from ty) where
tab ! col = UnsafeExpression $
renderSQL tab <> "." <> renderSQL col
instance (Has tab (Join lat from) row, Has col row ty, tys ~ '[ty])
=> IsQualified tab col (NP (Expression 'Ungrouped lat with db params from) tys) where
tab ! col = tab ! col :* Nil
instance (Has tab (Join lat from) row, Has col row ty, column ~ (col ::: ty))
=> IsQualified tab col
(Aliased (Expression 'Ungrouped lat with db params from) column) where
tab ! col = tab ! col `As` col
instance (Has tab (Join lat from) row, Has col row ty, columns ~ '[col ::: ty])
=> IsQualified tab col
(NP (Aliased (Expression 'Ungrouped lat with db params from)) columns) where
tab ! col = tab ! col :* Nil
instance
( HasUnique tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
) => IsLabel col
(Expression ('Grouped bys) lat with db params from ty) where
fromLabel = UnsafeExpression $ renderSQL (Alias @col)
instance
( HasUnique tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
, tys ~ '[ty]
) => IsLabel col
(NP (Expression ('Grouped bys) lat with db params from) tys) where
fromLabel = fromLabel @col :* Nil
instance
( HasUnique tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
, column ~ (col ::: ty)
) => IsLabel col
(Aliased (Expression ('Grouped bys) lat with db params from) column) where
fromLabel = fromLabel @col `As` Alias
instance
( HasUnique tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
, columns ~ '[col ::: ty]
) => IsLabel col
(NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where
fromLabel = fromLabel @col :* Nil
instance
( Has tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
) => IsQualified tab col
(Expression ('Grouped bys) lat with db params from ty) where
tab ! col = UnsafeExpression $
renderSQL tab <> "." <> renderSQL col
instance
( Has tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
, tys ~ '[ty]
) => IsQualified tab col
(NP (Expression ('Grouped bys) lat with db params from) tys) where
tab ! col = tab ! col :* Nil
instance
( Has tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
, column ~ (col ::: ty)
) => IsQualified tab col
(Aliased (Expression ('Grouped bys) lat with db params from) column) where
tab ! col = tab ! col `As` col
instance
( Has tab (Join lat from) row
, Has col row ty
, GroupedBy tab col bys
, columns ~ '[col ::: ty]
) => IsQualified tab col
(NP (Aliased (Expression ('Grouped bys) lat with db params from)) columns) where
tab ! col = tab ! col :* Nil
instance (KnownSymbol label, label `In` labels) => IsPGlabel label
(Expression grp lat with db params from (null ('PGenum labels))) where
label = UnsafeExpression $ renderSQL (PGlabel @label)
unsafeBinaryOp :: ByteString -> Operator ty0 ty1 ty2
unsafeBinaryOp op x y = UnsafeExpression $ parenthesized $
renderSQL x <+> op <+> renderSQL y
unsafeLeftOp :: ByteString -> x --> y
unsafeLeftOp op x = UnsafeExpression $ parenthesized $ op <+> renderSQL x
unsafeRightOp :: ByteString -> x --> y
unsafeRightOp op x = UnsafeExpression $ parenthesized $ renderSQL x <+> op
unsafeFunction :: ByteString -> x --> y
unsafeFunction fun x = UnsafeExpression $
fun <> parenthesized (renderSQL x)
function
:: (Has sch db schema, Has fun schema ('Function ('[x] :=> 'Returns y)))
=> QualifiedAlias sch fun
-> Fun db x y
function = unsafeFunction . renderSQL
unsafeFunctionN :: SListI xs => ByteString -> xs ---> y
unsafeFunctionN fun xs = UnsafeExpression $
fun <> parenthesized (renderCommaSeparated renderSQL xs)
functionN
:: ( Has sch db schema
, Has fun schema ('Function (xs :=> 'Returns y))
, SListI xs )
=> QualifiedAlias sch fun
-> FunN db xs y
functionN = unsafeFunctionN . renderSQL
instance
Num (Expression grp lat with db params from (null 'PGint2)) where
(+) = unsafeBinaryOp "+"
(-) = unsafeBinaryOp "-"
(*) = unsafeBinaryOp "*"
abs = unsafeFunction "abs"
signum = unsafeFunction "sign"
fromInteger
= UnsafeExpression
. parenthesized
. (<> " :: int2")
. toStrict
. toLazyByteString
. int16Dec
. fromInteger
instance
Num (Expression grp lat with db params from (null 'PGint4)) where
(+) = unsafeBinaryOp "+"
(-) = unsafeBinaryOp "-"
(*) = unsafeBinaryOp "*"
abs = unsafeFunction "abs"
signum = unsafeFunction "sign"
fromInteger
= UnsafeExpression
. parenthesized
. (<> " :: int4")
. toStrict
. toLazyByteString
. int32Dec
. fromInteger
instance
Num (Expression grp lat with db params from (null 'PGint8)) where
(+) = unsafeBinaryOp "+"
(-) = unsafeBinaryOp "-"
(*) = unsafeBinaryOp "*"
abs = unsafeFunction "abs"
signum = unsafeFunction "sign"
fromInteger x =
let
y = fromInteger x
in
if y == minBound
then fromInteger (x+1) - 1
else UnsafeExpression
. parenthesized
. (<> " :: int8")
. toStrict
. toLazyByteString
$ int64Dec y
instance
Num (Expression grp lat with db params from (null 'PGfloat4)) where
(+) = unsafeBinaryOp "+"
(-) = unsafeBinaryOp "-"
(*) = unsafeBinaryOp "*"
abs = unsafeFunction "abs"
signum = unsafeFunction "sign"
fromInteger x
= UnsafeExpression
. parenthesized
. (<> " :: float4") $
let
y = fromInteger x
decimal = toStrict . toLazyByteString . floatDec
in
if isNaN y || isInfinite y
then singleQuotedUtf8 (decimal y)
else decimal y
instance
Num (Expression grp lat with db params from (null 'PGfloat8)) where
(+) = unsafeBinaryOp "+"
(-) = unsafeBinaryOp "-"
(*) = unsafeBinaryOp "*"
abs = unsafeFunction "abs"
signum = unsafeFunction "sign"
fromInteger x
= UnsafeExpression
. parenthesized
. (<> " :: float8") $
let
y = fromInteger x
decimal = toStrict . toLazyByteString . doubleDec
in
if isNaN y || isInfinite y
then singleQuotedUtf8 (decimal y)
else decimal y
instance
Num (Expression grp lat with db params from (null 'PGnumeric)) where
(+) = unsafeBinaryOp "+"
(-) = unsafeBinaryOp "-"
(*) = unsafeBinaryOp "*"
abs = unsafeFunction "abs"
signum = unsafeFunction "sign"
fromInteger
= UnsafeExpression
. parenthesized
. (<> " :: numeric")
. toStrict
. toLazyByteString
. scientificBuilder
. fromInteger
instance Fractional
(Expression grp lat with db params from (null 'PGfloat4)) where
(/) = unsafeBinaryOp "/"
fromRational x
= UnsafeExpression
. parenthesized
. (<> " :: float4") $
let
y = fromRational x
decimal = toStrict . toLazyByteString . floatDec
in
if isNaN y || isInfinite y
then singleQuotedUtf8 (decimal y)
else decimal y
instance Fractional
(Expression grp lat with db params from (null 'PGfloat8)) where
(/) = unsafeBinaryOp "/"
fromRational x
= UnsafeExpression
. parenthesized
. (<> " :: float8") $
let
y = fromRational x
decimal = toStrict . toLazyByteString . doubleDec
in
if isNaN y || isInfinite y
then singleQuotedUtf8 (decimal y)
else decimal y
instance Fractional
(Expression grp lat with db params from (null 'PGnumeric)) where
(/) = unsafeBinaryOp "/"
fromRational
= UnsafeExpression
. parenthesized
. (<> " :: numeric")
. toStrict
. toLazyByteString
. scientificBuilder
. fromRational
instance Floating
(Expression grp lat with db params from (null 'PGfloat4)) where
pi = UnsafeExpression "pi()"
exp = unsafeFunction "exp"
log = unsafeFunction "ln"
sqrt = unsafeFunction "sqrt"
b ** x = UnsafeExpression $
"power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
logBase b y = log y / log b
sin = unsafeFunction "sin"
cos = unsafeFunction "cos"
tan = unsafeFunction "tan"
asin = unsafeFunction "asin"
acos = unsafeFunction "acos"
atan = unsafeFunction "atan"
sinh x = (exp x - exp (-x)) / 2
cosh x = (exp x + exp (-x)) / 2
tanh x = sinh x / cosh x
asinh x = log (x + sqrt (x*x + 1))
acosh x = log (x + sqrt (x*x - 1))
atanh x = log ((1 + x) / (1 - x)) / 2
instance Floating
(Expression grp lat with db params from (null 'PGfloat8)) where
pi = UnsafeExpression "pi()"
exp = unsafeFunction "exp"
log = unsafeFunction "ln"
sqrt = unsafeFunction "sqrt"
b ** x = UnsafeExpression $
"power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
logBase b y = log y / log b
sin = unsafeFunction "sin"
cos = unsafeFunction "cos"
tan = unsafeFunction "tan"
asin = unsafeFunction "asin"
acos = unsafeFunction "acos"
atan = unsafeFunction "atan"
sinh x = (exp x - exp (-x)) / 2
cosh x = (exp x + exp (-x)) / 2
tanh x = sinh x / cosh x
asinh x = log (x + sqrt (x*x + 1))
acosh x = log (x + sqrt (x*x - 1))
atanh x = log ((1 + x) / (1 - x)) / 2
instance Floating
(Expression grp lat with db params from (null 'PGnumeric)) where
pi = UnsafeExpression "pi()"
exp = unsafeFunction "exp"
log = unsafeFunction "ln"
sqrt = unsafeFunction "sqrt"
b ** x = UnsafeExpression $
"power(" <> renderSQL b <> ", " <> renderSQL x <> ")"
logBase b y = log y / log b
sin = unsafeFunction "sin"
cos = unsafeFunction "cos"
tan = unsafeFunction "tan"
asin = unsafeFunction "asin"
acos = unsafeFunction "acos"
atan = unsafeFunction "atan"
sinh x = (exp x - exp (-x)) / 2
cosh x = (exp x + exp (-x)) / 2
tanh x = sinh x / cosh x
asinh x = log (x + sqrt (x*x + 1))
acosh x = log (x + sqrt (x*x - 1))
atanh x = log ((1 + x) / (1 - x)) / 2
class PGSubset ty where
(@>) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
(@>) = unsafeBinaryOp "@>"
(<@) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
(<@) = unsafeBinaryOp "<@"
instance PGSubset 'PGjsonb
instance PGSubset 'PGtsquery
instance PGSubset ('PGvararray ty)
instance PGSubset ('PGrange ty)
class PGIntersect ty where
(@&&) :: Operator (null0 ty) (null1 ty) ('Null 'PGbool)
(@&&) = unsafeBinaryOp "&&"
instance PGIntersect ('PGvararray ty)
instance PGIntersect ('PGrange ty)
instance IsString
(Expression grp lat with db params from (null 'PGtext)) where
fromString
= UnsafeExpression
. parenthesized
. (<> " :: text")
. escapeQuotedString
instance IsString
(Expression grp lat with db params from (null 'PGtsvector)) where
fromString
= UnsafeExpression
. parenthesized
. (<> " :: tsvector")
. escapeQuotedString
instance IsString
(Expression grp lat with db params from (null 'PGtsquery)) where
fromString
= UnsafeExpression
. parenthesized
. (<> " :: tsquery")
. escapeQuotedString
instance Semigroup
(Expression grp lat with db params from (null ('PGvararray ty))) where
(<>) = unsafeBinaryOp "||"
instance Semigroup
(Expression grp lat with db params from (null 'PGjsonb)) where
(<>) = unsafeBinaryOp "||"
instance Semigroup
(Expression grp lat with db params from (null 'PGtext)) where
(<>) = unsafeBinaryOp "||"
instance Semigroup
(Expression grp lat with db params from (null 'PGtsvector)) where
(<>) = unsafeBinaryOp "||"
instance Monoid
(Expression grp lat with db params from (null 'PGtext)) where
mempty = fromString ""
mappend = (<>)
instance Monoid
(Expression grp lat with db params from (null 'PGtsvector)) where
mempty = fromString ""
mappend = (<>)