Add support for PostgreSQL's anonymous row types

Author: shane-circuithub

changelog.d/20250514_235520_shane.obrien_Record.md

@@ -0,0 +1,4 @@
+### Added
+
+- `Rel8.Record`, which adds experimental support for PostgreSQL's anonymous row types.
+- Add `elem` and `elem1` to `Rel8.Array` for testing if an element is contained in `[]` and `NonEmpty` `Expr`s.

rel8.cabal

@@ -67,6 +67,7 @@ library
     Rel8.Expr.Num
     Rel8.Expr.Text
     Rel8.Expr.Time
+    Rel8.Record
     Rel8.Tabulate
 
   other-modules:

src/Rel8/Array.hs

@@ -1,3 +1,7 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Rel8.Array
   (
     -- ** @ListTable@
@@ -6,13 +10,15 @@ module Rel8.Array
   , index, indexExpr
   , last, lastExpr
   , length, lengthExpr
+  , elem
 
     -- ** @NonEmptyTable@
   , NonEmptyTable
   , head1, head1Expr
   , index1, index1Expr
   , last1, last1Expr
   , length1, length1Expr
+  , elem1
 
     -- ** Unsafe
   , unsafeSubscript
@@ -21,11 +27,34 @@ module Rel8.Array
 where
 
 -- base
-import Prelude hiding (head, last, length)
+import Data.List.NonEmpty (NonEmpty)
+import Prelude hiding (elem, head, last, length)
 
 -- rel8
+import Rel8.Expr (Expr)
+import Rel8.Expr.Array (listOf, nonEmptyOf)
+import Rel8.Expr.Function (rawBinaryOperator)
 import Rel8.Expr.List
 import Rel8.Expr.NonEmpty
 import Rel8.Expr.Subscript
+import Rel8.Schema.Null (Sql)
 import Rel8.Table.List
 import Rel8.Table.NonEmpty
+import Rel8.Type.Eq (DBEq)
+
+
+-- | @'elem' a as@ tests whether @a@ is an element of the list @as@.
+elem :: Sql DBEq a => Expr a -> Expr [a] -> Expr Bool
+elem = (<@) . listOf . pure
+  where
+    (<@) = rawBinaryOperator "<@"
+infix 4 `elem`
+
+
+-- | @'elem1' a as@ tests whether @a@ is an element of the non-empty list
+-- @as@.
+elem1 :: Sql DBEq a => Expr a -> Expr (NonEmpty a) -> Expr Bool
+elem1 = (<@) . nonEmptyOf . pure
+  where
+    (<@) = rawBinaryOperator "<@"
+infix 4 `elem1`

src/Rel8/Record.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Rel8.Record (
+  Record (Record),
+  row,
+) where
+
+-- base
+import Data.Functor.Contravariant ((>$<))
+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.Table (FromExprs, Table, fromResult, toColumns, toResult)
+import Rel8.Table.Eq (EqTable)
+import Rel8.Table.Ord (OrdTable)
+import Rel8.Type (DBType, typeInformation)
+import Rel8.Type.Composite (decodeComposite, encodeComposite)
+import Rel8.Type.Eq (DBEq)
+import Rel8.Type.Information (TypeInformation (TypeInformation))
+import Rel8.Type.Ord (DBOrd)
+import qualified Rel8.Type.Information
+
+
+{-| 'Record' is Rel8's support for PostgreSQL's anonymous record types. Any
+'Table' of 'Expr's can be converted to a 'Record' with 'row'.
+
+Note that all of PostgreSQL's limitations on anonymous record types also
+apply to @Record@. For example, you won't be able to cast to 'Data.Text.Text'
+and back again like you can for other types. This also means that
+'Rel8.catListTable' will fail on nested 'Rel8.ListTable's that contain
+'Record's.
+-}
+newtype Record a = Record (FromExprs a)
+
+
+instance Table Expr a => DBType (Record a) where
+  typeInformation =
+    TypeInformation
+      { decode = Record . fromResult @_ @a <$> decodeComposite
+      , encode = toResult @_ @a . (\(Record a) -> a) >$< encodeComposite
+      , delimiter = ','
+      , typeName = "record"
+      }
+
+
+instance EqTable a => DBEq (Record a)
+
+
+instance OrdTable a => DBOrd (Record a)
+
+
+-- | Convert a 'Table' of 'Expr's to a single anonymous record 'Expr'.
+row :: Table Expr a => a -> Expr (Record a)
+row = fromPrimExpr . Opaleye.FunExpr "ROW" . hfoldMap (pure . toPrimExpr) . toColumns

src/Rel8/Type/Composite.hs

@@ -18,6 +18,7 @@ module Rel8.Type.Composite
   ( Composite( Composite )
   , DBComposite( compositeFields, compositeTypeName )
   , compose, decompose
+  , decodeComposite, encodeComposite
   )
 where
 
@@ -52,7 +53,7 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye ( castExpr, fromPrimExpr, toPrimExpr )
-import Rel8.Schema.HTable ( HTable, hfield, hspecs, htabulate, htabulateA )
+import Rel8.Schema.HTable (HTable, hfield, hfoldMap, hspecs, htabulate, htabulateA)
 import Rel8.Schema.Name ( Name( Name ) )
 import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
 import Rel8.Schema.QualifiedName (QualifiedName)
@@ -97,19 +98,27 @@ newtype Composite a = Composite
   }
 
 
+decodeComposite :: HTable t => Decoder (t Result)
+decodeComposite =
+  Decoder
+    { binary = Decoders.composite decoder
+    , text = parser
+    }
+
+
+encodeComposite :: forall t. HTable t => Encoder (t Result)
+encodeComposite =
+  Encoder
+    { binary = Encoders.composite (encoder @t)
+    , text = builder
+    , quote = quoter . litHTable
+    }
+
+
 instance DBComposite a => DBType (Composite a) where
   typeInformation = TypeInformation
-    { decode =
-        Decoder
-          { binary = Decoders.composite (Composite . fromResult @_ @(HKD a Expr) <$> decoder)
-          , text = fmap (Composite . fromResult @_ @(HKD a Expr)) . parser
-          }
-    , encode =
-        Encoder
-          { binary = Encoders.composite (toResult @_ @(HKD a Expr) . unComposite >$< encoder)
-          , text = builder . toResult @_ @(HKD a Expr) . unComposite
-          , quote = quoter . litHTable . toResult @_ @(HKD a Expr) . unComposite
-          }
+    { decode = Composite . fromResult @_ @(HKD a Expr) <$> decodeComposite
+    , encode = toResult @_ @(HKD a Expr) . unComposite >$< encodeComposite
     , delimiter = ','
     , typeName =
         TypeName
@@ -256,7 +265,4 @@ buildRow elements =
 
 
 quoter :: HTable t => t Expr -> Opaleye.PrimExpr
-quoter a = Opaleye.FunExpr "ROW" exprs
-  where
-    exprs = getConst $ htabulateA \field -> case hfield a field of
-      expr -> Const [toPrimExpr expr]
+quoter = Opaleye.FunExpr "ROW" . hfoldMap (pure . toPrimExpr)