Add more raw/unsafe escape hatches (#331)

- `rawFunction`, `rawBinaryOperator`, `rawAggregateFunction`, `unsafeCoerceExpr`, `unsafePrimExpr`, `unsafeSubscript`, `unsafeSubscripts` — these give more options for generating SQL expressions that Rel8 does not support natively.

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.
+

rel8.cabal

@@ -102,6 +102,7 @@ library
     Rel8.Expr.Sequence
     Rel8.Expr.Serialize
     Rel8.Expr.Show
+    Rel8.Expr.Subscript
     Rel8.Expr.Window
 
     Rel8.FCF

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

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)))

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

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

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

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
 

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

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
+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)