From c482564838876c51a215284a57fecf6386bdb41d Mon Sep 17 00:00:00 2001 From: Shane Date: Fri, 18 Oct 2024 11:12:20 +0100 Subject: [PATCH] Add more raw/unsafe escape hatches (#331) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively. --- .../20240701_173914_shane.obrien_raw.md | 4 ++ rel8.cabal | 1 + src/Rel8.hs | 7 +- src/Rel8/Aggregate/Function.hs | 9 ++- src/Rel8/Array.hs | 5 ++ src/Rel8/Expr/Default.hs | 2 +- src/Rel8/Expr/Function.hs | 38 ++++++----- src/Rel8/Expr/Opaleye.hs | 24 ++++++- src/Rel8/Expr/Subscript.hs | 65 +++++++++++++++++++ src/Rel8/Schema/QualifiedName.hs | 12 +++- 10 files changed, 143 insertions(+), 24 deletions(-) create mode 100644 changelog.d/20240701_173914_shane.obrien_raw.md create mode 100644 src/Rel8/Expr/Subscript.hs diff --git a/changelog.d/20240701_173914_shane.obrien_raw.md b/changelog.d/20240701_173914_shane.obrien_raw.md new file mode 100644 index 00000000..52b6f932 --- /dev/null +++ b/changelog.d/20240701_173914_shane.obrien_raw.md @@ -0,0 +1,4 @@ +### Added + +- `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively. + diff --git a/rel8.cabal b/rel8.cabal index 9b864f70..a0e149cc 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -102,6 +102,7 @@ library Rel8.Expr.Sequence Rel8.Expr.Serialize Rel8.Expr.Show + Rel8.Expr.Subscript Rel8.Expr.Window Rel8.FCF diff --git a/src/Rel8.hs b/src/Rel8.hs index dc612730..6a091f63 100644 --- a/src/Rel8.hs +++ b/src/Rel8.hs @@ -170,7 +170,9 @@ module Rel8 , Sql , litExpr , unsafeCastExpr + , unsafeCoerceExpr , unsafeLiteral + , unsafePrimExpr -- ** @null@ , NotNull @@ -208,6 +210,8 @@ module Rel8 , function , binaryOperator , queryFunction + , rawFunction + , rawBinaryOperator -- * Queries , Query @@ -295,6 +299,7 @@ module Rel8 , and, andOn , or, orOn , aggregateFunction + , rawAggregateFunction , mode, modeOn , percentile, percentileOn @@ -412,7 +417,7 @@ import Rel8.Expr.Default import Rel8.Expr.Eq import Rel8.Expr.Function import Rel8.Expr.Null -import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeLiteral) +import Rel8.Expr.Opaleye (unsafeCastExpr, unsafeCoerceExpr, unsafeLiteral, unsafePrimExpr) import Rel8.Expr.Ord import Rel8.Expr.Order import Rel8.Expr.Serialize diff --git a/src/Rel8/Aggregate/Function.hs b/src/Rel8/Aggregate/Function.hs index b8c3537c..7e5f41cb 100644 --- a/src/Rel8/Aggregate/Function.hs +++ b/src/Rel8/Aggregate/Function.hs @@ -3,6 +3,7 @@ module Rel8.Aggregate.Function ( aggregateFunction, + rawAggregateFunction, ) where -- base @@ -31,10 +32,14 @@ aggregateFunction :: (Table Expr i, Sql DBType a) => QualifiedName -> Aggregator1 i (Expr a) -aggregateFunction name = +aggregateFunction name = castExpr <$> rawAggregateFunction name + + +rawAggregateFunction :: Table Expr i => QualifiedName -> Aggregator1 i (Expr a) +rawAggregateFunction name = unsafeMakeAggregator id - (castExpr . fromPrimExpr . fromColumn) + (fromPrimExpr . fromColumn) Empty (Opaleye.makeAggrExplicit unpackspec (Opaleye.AggrOther (showQualifiedName name))) diff --git a/src/Rel8/Array.hs b/src/Rel8/Array.hs index 283b034f..ad602c61 100644 --- a/src/Rel8/Array.hs +++ b/src/Rel8/Array.hs @@ -13,6 +13,10 @@ module Rel8.Array , index1, index1Expr , last1, last1Expr , length1, length1Expr + + -- ** Unsafe + , unsafeSubscript + , unsafeSubscripts ) where @@ -22,5 +26,6 @@ import Prelude hiding (head, last, length) -- rel8 import Rel8.Expr.List import Rel8.Expr.NonEmpty +import Rel8.Expr.Subscript import Rel8.Table.List import Rel8.Table.NonEmpty diff --git a/src/Rel8/Expr/Default.hs b/src/Rel8/Expr/Default.hs index 7465d658..1c49e0b8 100644 --- a/src/Rel8/Expr/Default.hs +++ b/src/Rel8/Expr/Default.hs @@ -24,7 +24,7 @@ import Rel8.Expr.Opaleye ( fromPrimExpr ) -- @DEFAULT@ value. Trying to use @unsafeDefault@ where there is no default -- will cause a runtime crash -- --- 3. @DEFAULT@ values can not be transformed. For example, the innocuous Rel8 +-- 3. @DEFAULT@ values cannot be transformed. For example, the innocuous Rel8 -- code @unsafeDefault + 1@ will crash, despite type checking. -- -- Also note, PostgreSQL's syntax rules mean that @DEFAULT@ can only appear in diff --git a/src/Rel8/Expr/Function.hs b/src/Rel8/Expr/Function.hs index cc4f8749..6ea7bb64 100644 --- a/src/Rel8/Expr/Function.hs +++ b/src/Rel8/Expr/Function.hs @@ -11,7 +11,9 @@ module Rel8.Expr.Function ( Arguments , function , primFunction + , rawFunction , binaryOperator + , rawBinaryOperator ) where @@ -22,19 +24,20 @@ import Prelude -- opaleye import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye --- pretty -import Text.PrettyPrint (parens, text) - -- rel8 import {-# SOURCE #-} Rel8.Expr (Expr) import Rel8.Expr.Opaleye ( castExpr , fromPrimExpr, toPrimExpr, zipPrimExprsWith ) -import Rel8.Schema.Escape (escape) import Rel8.Schema.HTable (hfoldMap) import Rel8.Schema.Null ( Sql ) -import Rel8.Schema.QualifiedName (QualifiedName (..), showQualifiedName) +import Rel8.Schema.QualifiedName + ( QualifiedName (..) + , showQualifiedName + , showQualifiedOperator + + ) import Rel8.Table (Table, toColumns) import Rel8.Type ( DBType ) @@ -59,7 +62,13 @@ instance {-# OVERLAPS #-} Arguments () where -- the arguments @arguments@ returning an @'Expr' a@. function :: (Arguments arguments, Sql DBType a) => QualifiedName -> arguments -> Expr a -function qualified = castExpr . fromPrimExpr . primFunction qualified +function qualified = castExpr . rawFunction qualified + + +-- | A less safe version of 'function' that does not wrap the return value in +-- a cast. +rawFunction :: Arguments arguments => QualifiedName -> arguments -> Expr a +rawFunction qualified = fromPrimExpr . primFunction qualified primFunction :: Arguments arguments @@ -72,14 +81,13 @@ primFunction qualified = Opaleye.FunExpr name . arguments -- | Construct an expression by applying an infix binary operator to two -- operands. binaryOperator :: Sql DBType c => QualifiedName -> Expr a -> Expr b -> Expr c -binaryOperator operator a b = - castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b - where - name = showQualifiedOperator operator +binaryOperator operator a b = castExpr $ rawBinaryOperator operator a b -showQualifiedOperator :: QualifiedName -> String -showQualifiedOperator QualifiedName {schema = mschema, ..} = case mschema of - Nothing -> name - Just schema -> - show $ text "OPERATOR" <> parens (escape schema <> text "." <> text name) +-- | A less safe version of 'binaryOperator' that does not wrap the return +-- value in a cast. +rawBinaryOperator :: QualifiedName -> Expr a -> Expr b -> Expr c +rawBinaryOperator operator a b = + zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b + where + name = showQualifiedOperator operator diff --git a/src/Rel8/Expr/Opaleye.hs b/src/Rel8/Expr/Opaleye.hs index 30e7c89a..983b79b7 100644 --- a/src/Rel8/Expr/Opaleye.hs +++ b/src/Rel8/Expr/Opaleye.hs @@ -9,6 +9,8 @@ module Rel8.Expr.Opaleye ( castExpr, unsafeCastExpr , scastExpr, sunsafeCastExpr + , unsafeCoerceExpr + , unsafePrimExpr , unsafeLiteral , fromPrimExpr, toPrimExpr, mapPrimExpr, zipPrimExprsWith, traversePrimExpr , toColumn, fromColumn, traverseFieldP @@ -44,6 +46,22 @@ unsafeCastExpr = case typeInformation @(Unnullify b) of TypeInformation {typeName} -> sunsafeCastExpr typeName +-- | Change the type of an 'Expr', without a cast. Even more unsafe than +-- 'unsafeCastExpr'. Only use this if you are certain that the @typeName@s of +-- @a@ and @b@ refer to exactly the same PostgreSQL type. +unsafeCoerceExpr :: Expr a -> Expr b +unsafeCoerceExpr (Expr a) = Expr a + + +-- | Import a raw 'Opaleye.PrimExpr' from @opaleye@, without a cast. +-- +-- This is an escape hatch, and can be used if Rel8 cannot adequately express +-- the expression you need. If you find yourself using this function, please +-- let us know, as it may indicate that something is missing from Rel8! +unsafePrimExpr :: Opaleye.PrimExpr -> Expr a +unsafePrimExpr = fromPrimExpr + + scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a scastExpr TypeInformation {typeName} = sunsafeCastExpr typeName @@ -56,9 +74,9 @@ sunsafeCastExpr name = -- | Unsafely construct an expression from literal SQL. -- --- This is an escape hatch, and can be used if Rel8 can not adequately express --- the query you need. If you find yourself using this function, please let us --- know, as it may indicate that something is missing from Rel8! +-- This is an escape hatch, and can be used if Rel8 cannot adequately express +-- the expression you need. If you find yourself using this function, please let +-- us know, as it may indicate that something is missing from Rel8! unsafeLiteral :: String -> Expr a unsafeLiteral = Expr . Opaleye.ConstExpr . Opaleye.OtherLit diff --git a/src/Rel8/Expr/Subscript.hs b/src/Rel8/Expr/Subscript.hs new file mode 100644 index 00000000..c72d28d7 --- /dev/null +++ b/src/Rel8/Expr/Subscript.hs @@ -0,0 +1,65 @@ +{-# language FlexibleContexts #-} +{-# language MonoLocalBinds #-} + +module Rel8.Expr.Subscript + ( unsafeSubscript + , unsafeSubscripts + ) +where + +-- base +import Data.Foldable (foldl') +import Prelude + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye + +-- rel8 +import Rel8.Expr (Expr) +import Rel8.Expr.Opaleye (fromPrimExpr, toPrimExpr) +import Rel8.Schema.HTable (hfoldMap) +import Rel8.Schema.Null (Sql, Unnullify) +import Rel8.Table (Table, toColumns) +import Rel8.Type (DBType, typeInformation) +import Rel8.Type.Array (extractArrayElement) +import Rel8.Type.Information (TypeInformation) + + +-- | @'unsafeSubscript' a i@ will generate the SQL @a[i]@. +-- +-- Note that this function is not type checked and the generated SQL has no +-- casts. This is only intended an escape hatch to be used if Rel8 cannot +-- otherwise express the expression you need. If you find yourself using this +-- function, please let us know, as it may indicate that something is missing +-- from Rel8! +unsafeSubscript :: Sql DBType b => Expr a -> Expr i -> Expr b +unsafeSubscript = sunsafeSubscript typeInformation + + +-- | @'unsafeSubscripts' a (i, j)@ will generate the SQL @a[i][j]@. +-- +-- Note that this function is not type checked and the generated SQL has no +-- casts. This is only intended an escape hatch to be used if Rel8 cannot +-- otherwise express the expression you need. If you find yourself using this +-- function, please let us know, as it may indicate that something is missing +-- from Rel8! +unsafeSubscripts :: (Table Expr i, Sql DBType b) => Expr a -> i -> Expr b +unsafeSubscripts = sunsafeSubscripts typeInformation + + +sunsafeSubscript :: TypeInformation (Unnullify b) -> Expr a -> Expr i -> Expr b +sunsafeSubscript info array i = + fromPrimExpr . extractArrayElement info $ + Opaleye.ArrayIndex (toPrimExpr array) (toPrimExpr i) + + +sunsafeSubscripts :: Table Expr i => TypeInformation (Unnullify b) -> Expr a -> i -> Expr b +sunsafeSubscripts info array i = + fromPrimExpr $ extractArrayElement info $ primSubscripts array indices + where + indices = hfoldMap (pure . toPrimExpr) $ toColumns i + + +primSubscripts :: Expr a -> [Opaleye.PrimExpr] -> Opaleye.PrimExpr +primSubscripts array indices = + foldl' Opaleye.ArrayIndex (toPrimExpr array) indices diff --git a/src/Rel8/Schema/QualifiedName.hs b/src/Rel8/Schema/QualifiedName.hs index 185105e6..ce55b090 100644 --- a/src/Rel8/Schema/QualifiedName.hs +++ b/src/Rel8/Schema/QualifiedName.hs @@ -8,6 +8,7 @@ module Rel8.Schema.QualifiedName ( QualifiedName (..) , ppQualifiedName , showQualifiedName + , showQualifiedOperator ) where @@ -17,7 +18,7 @@ import Data.String (IsString, fromString) import Prelude -- pretty -import Text.PrettyPrint (Doc, text) +import Text.PrettyPrint (Doc, parens, text) -- rel8 import Rel8.Schema.Escape (escape) @@ -51,4 +52,11 @@ ppQualifiedName QualifiedName {schema = mschema, ..} = case mschema of showQualifiedName :: QualifiedName -> String -showQualifiedName = show . ppQualifiedName \ No newline at end of file +showQualifiedName = show . ppQualifiedName + + +showQualifiedOperator :: QualifiedName -> String +showQualifiedOperator QualifiedName {schema = mschema, ..} = case mschema of + Nothing -> name + Just schema -> + show $ text "OPERATOR" <> parens (escape schema <> text "." <> text name)