unnest support

src/Rel8.hs

@@ -100,6 +100,8 @@ module Rel8
   , nameListTable
   , many
   , manyExpr
+  , catListTable
+  , catList
 
     -- ** @NonEmptyTable@
   , NonEmptyTable
@@ -108,6 +110,8 @@ module Rel8
   , nameNonEmptyTable
   , some
   , someExpr
+  , catNonEmptyTable
+  , catNonEmpty
 
     -- ** @ADT@
   , ADT, ADTable, fromADT, toADT

src/Rel8/Query/List.hs

@@ -1,29 +1,52 @@
 {-# language FlexibleContexts #-}
-{-# language MonoLocalBinds #-}
+{-# language GADTs #-}
+{-# language NamedFieldPuns #-}
 
 module Rel8.Query.List
   ( many, some
   , manyExpr, someExpr
+  , catListTable, catNonEmptyTable
+  , catList, catNonEmpty
   )
 where
 
 -- base
+import Data.Functor.Identity ( runIdentity )
 import Data.List.NonEmpty ( NonEmpty )
 import Prelude
 
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
 -- rel8
-import Rel8.Expr ( Expr )
+import Rel8.Expr ( Col( E, unE ), Expr )
 import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )
+import Rel8.Expr.Opaleye ( mapPrimExpr )
 import Rel8.Query ( Query )
 import Rel8.Query.Aggregate ( aggregate )
 import Rel8.Query.Maybe ( optional )
-import Rel8.Schema.Null ( Sql )
-import Rel8.Table ( Table )
+import Rel8.Schema.HTable.Vectorize ( hunvectorize )
+import Rel8.Schema.Null ( Sql, Unnullify )
+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
+import Rel8.Table ( Table, fromColumns )
 import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
-import Rel8.Table.List ( ListTable )
+import Rel8.Table.List ( ListTable( ListTable ) )
 import Rel8.Table.Maybe ( maybeTable )
-import Rel8.Table.NonEmpty ( NonEmptyTable )
-import Rel8.Type ( DBType )
+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Array ( extractArrayElement )
+import Rel8.Type.Information ( TypeInformation )
+
+
+-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
+-- rows, this function will produce a 'Query' that returns one row containing
+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
+-- return exactly one row, with a @ListTable@ collecting all returned rows.
+-- 
+-- @many@ is analogous to 'Control.Applicative.many' from
+-- @Control.Applicative@.
+many :: Table Expr a => Query a -> Query (ListTable a)
+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
 
 
 -- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns
@@ -38,17 +61,6 @@ some :: Table Expr a => Query a -> Query (NonEmptyTable a)
 some = aggregate . fmap nonEmptyAgg
 
 
--- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0
--- rows, this function will produce a 'Query' that returns one row containing
--- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will
--- return exactly one row, with a @ListTable@ collecting all returned rows.
--- 
--- @many@ is analogous to 'Control.Applicative.many' from
--- @Control.Applicative@.
-many :: Table Expr a => Query a -> Query (ListTable a)
-many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg
-
-
 -- | A version of 'many' specialised to single expressions.
 manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])
 manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr
@@ -57,3 +69,27 @@ manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr
 -- | A version of 'many' specialised to single expressions.
 someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))
 someExpr = aggregate . fmap nonEmptyAggExpr
+
+
+catListTable :: Table Expr a => ListTable a -> Query a
+catListTable (ListTable as) = pure $ fromColumns $ runIdentity $
+  hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
+
+
+catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a
+catNonEmptyTable (NonEmptyTable as) = pure $ fromColumns $ runIdentity $
+  hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
+
+
+catList :: Sql DBType a => Expr [a] -> Query (Expr a)
+catList = pure . sunnest typeInformation
+
+
+catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)
+catNonEmpty = pure . sunnest typeInformation
+
+
+sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a
+sunnest info = mapPrimExpr $
+  extractArrayElement info .
+  Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")

src/Rel8/Schema/HTable/Vectorize.hs

@@ -46,7 +46,7 @@ import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )
 import Rel8.Type.Information ( TypeInformation )
 
 -- semialign
-import Data.Zip ( Unzip, Repeat, Zippy(..) )
+import Data.Zip ( Unzip, Zip, Zippy(..) )
 import Rel8.FCF
 import Rel8.Schema.HTable.MapTable
 import GHC.Generics (Generic)
@@ -106,7 +106,7 @@ hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->
 {-# INLINABLE hvectorize #-}
 
 
-hunvectorize :: (HTable t, Repeat f, Vector list)
+hunvectorize :: (HTable t, Zip f, Vector list)
   => (forall labels necessity a. ()
     => SSpec ('Spec labels necessity a)
     -> context ('Spec labels 'Required (list a))

src/Rel8/Type/Array.hs

@@ -5,7 +5,7 @@
 {-# language ViewPatterns #-}
 
 module Rel8.Type.Array
-  ( array, encodeArrayElement
+  ( array, encodeArrayElement, extractArrayElement
   , listTypeInformation
   , nonEmptyTypeInformation
   )
@@ -92,3 +92,9 @@ encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
 encodeArrayElement info
   | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
   | otherwise = id
+
+
+extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
+extractArrayElement info
+  | isArray info = flip Opaleye.CompositeExpr "f1"
+  | otherwise = id

tests/Main.hs

@@ -694,11 +694,16 @@ testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \t
   rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool
 
   transaction \connection -> do
-    selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do
-      Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)
+    selected <- liftIO $ Rel8.select connection do
+      Rel8.many $ Rel8.values (map Rel8.lit rows)
 
     selected === [foldMap pure rows]
 
+    selected' <- liftIO $ Rel8.select connection $ Rel8.catListTable =<< do
+      Rel8.many $ Rel8.values (map Rel8.lit rows)
+
+    selected' === rows
+
 
 data NestedMaybeTable f = NestedMaybeTable
   { nmt1 :: Rel8.Column f Bool