diff --git a/changelog.d/20250514_235520_shane.obrien_Record.md b/changelog.d/20250514_235520_shane.obrien_Record.md new file mode 100644 index 00000000..96a7d71c --- /dev/null +++ b/changelog.d/20250514_235520_shane.obrien_Record.md @@ -0,0 +1,3 @@ +### Added + +- `Rel8.Record`, which adds experimental support for PostgreSQL's anonymous row types. diff --git a/changelog.d/20250701_105439_shane.obrien_elem.md b/changelog.d/20250701_105439_shane.obrien_elem.md new file mode 100644 index 00000000..d59d0cf9 --- /dev/null +++ b/changelog.d/20250701_105439_shane.obrien_elem.md @@ -0,0 +1,3 @@ +### Added + +- Add `elem` and `elem1` to `Rel8.Array` for testing if an element is contained in `[]` and `NonEmpty` `Expr`s. diff --git a/rel8.cabal b/rel8.cabal index 06163517..0fec2920 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -67,6 +67,7 @@ library Rel8.Expr.Num Rel8.Expr.Text Rel8.Expr.Time + Rel8.Record Rel8.Tabulate other-modules: diff --git a/src/Rel8/Array.hs b/src/Rel8/Array.hs index ad602c61..d8447945 100644 --- a/src/Rel8/Array.hs +++ b/src/Rel8/Array.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} + module Rel8.Array ( -- ** @ListTable@ @@ -6,6 +10,7 @@ module Rel8.Array , index, indexExpr , last, lastExpr , length, lengthExpr + , elem -- ** @NonEmptyTable@ , NonEmptyTable @@ -13,6 +18,7 @@ module Rel8.Array , 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` diff --git a/src/Rel8/Record.hs b/src/Rel8/Record.hs new file mode 100644 index 00000000..106e6feb --- /dev/null +++ b/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 diff --git a/src/Rel8/Type/Composite.hs b/src/Rel8/Type/Composite.hs index d365ed7f..ef5ac1e5 100644 --- a/src/Rel8/Type/Composite.hs +++ b/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)