Add array concenation aggregators (#270)

changelog.d/20230826_034632_shane.obrien_array_cat.md

@@ -0,0 +1,40 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Removed
+
+- A bullet item for the Removed category.
+
+-->
+### Added
+
+- Added aggregators `listCat` and `nonEmptyCat` for folding a collection of lists into a single list by concatenation.
+
+<!--
+### Changed
+
+- A bullet item for the Changed category.
+
+-->
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

rel8.cabal

@@ -92,8 +92,10 @@ library
     Rel8.Expr.Opaleye
     Rel8.Expr.Ord
     Rel8.Expr.Order
+    Rel8.Expr.Read
     Rel8.Expr.Sequence
     Rel8.Expr.Serialize
+    Rel8.Expr.Show
     Rel8.Expr.Window
 
     Rel8.FCF

src/Rel8.hs

@@ -279,8 +279,10 @@ module Rel8
   , countRows
   , groupBy, groupByOn
   , listAgg, listAggOn, listAggExpr, listAggExprOn
+  , listCat, listCatOn, listCatExpr, listCatExprOn
   , mode
   , nonEmptyAgg, nonEmptyAggOn, nonEmptyAggExpr, nonEmptyAggExprOn
+  , nonEmptyCat, nonEmptyCatOn, nonEmptyCatExpr, nonEmptyCatExprOn
   , DBMax, max, maxOn
   , DBMin, min, minOn
   , DBSum, sum, sumOn, sumWhere, avg, avgOn

src/Rel8/Expr/Aggregate.hs

@@ -1,5 +1,7 @@
 {-# language DataKinds #-}
+{-# language DisambiguateRecordFields #-}
 {-# language FlexibleContexts #-}
+{-# language NamedFieldPuns #-}
 {-# language OverloadedStrings #-}
 {-# language ScopedTypeVariables #-}
 {-# language TypeFamilies #-}
@@ -19,15 +21,17 @@ module Rel8.Expr.Aggregate
   , distinctAggregate
   , filterWhereExplicit
   , listAggExpr, listAggExprOn, nonEmptyAggExpr, nonEmptyAggExprOn
+  , listCatExpr, listCatExprOn, nonEmptyCatExpr, nonEmptyCatExprOn
   , slistAggExpr, snonEmptyAggExpr
+  , slistCatExpr, snonEmptyCatExpr
   )
 where
 
 -- base
 import Data.Int ( Int64 )
 import Data.List.NonEmpty ( NonEmpty )
 import Data.String (IsString)
-import Prelude hiding ( and, max, min, null, or, sum )
+import Prelude hiding (and, max, min, null, or, show, sum)
 
 -- opaleye
 import qualified Opaleye.Aggregate as Opaleye
@@ -48,18 +52,22 @@ import Rel8.Aggregate.Fold (Fallback (Empty, Fallback))
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Array (sempty)
 import Rel8.Expr.Bool (false, true)
+import Rel8.Expr.Eq ((/=.))
 import Rel8.Expr.Opaleye
   ( castExpr
   , fromColumn
   , fromPrimExpr
   , toColumn
   , toPrimExpr
   )
+import Rel8.Expr.Read (sread)
+import Rel8.Expr.Show (show)
+import qualified Rel8.Expr.Text as Text
 import Rel8.Schema.Null ( Sql, Unnullify )
 import Rel8.Type ( DBType, typeInformation )
-import Rel8.Type.Array ( encodeArrayElement )
+import Rel8.Type.Array (arrayTypeName, encodeArrayElement)
 import Rel8.Type.Eq ( DBEq )
-import Rel8.Type.Information ( TypeInformation )
+import Rel8.Type.Information (TypeInformation)
 import Rel8.Type.Num ( DBNum )
 import Rel8.Type.Ord ( DBMax, DBMin )
 import Rel8.Type.String ( DBString )
@@ -267,6 +275,29 @@ nonEmptyAggExprOn :: Sql DBType a
 nonEmptyAggExprOn f = lmap f nonEmptyAggExpr
 
 
+-- | Concatenate lists into a single list.
+listCatExpr :: Sql DBType a => Aggregator' fold (Expr [a]) (Expr [a])
+listCatExpr = slistCatExpr typeInformation
+
+
+-- | Applies 'listCatExpr' to the column selected by the given function.
+listCatExprOn :: Sql DBType a
+  => (i -> Expr [a]) -> Aggregator' fold i (Expr [a])
+listCatExprOn f = lmap f listCatExpr
+
+
+-- | Concatenate non-empty lists into a single non-empty list.
+nonEmptyCatExpr :: Sql DBType a
+  => Aggregator1 (Expr (NonEmpty a)) (Expr (NonEmpty a))
+nonEmptyCatExpr = snonEmptyCatExpr typeInformation
+
+
+-- | Applies 'nonEmptyCatExpr' to the column selected by the given function.
+nonEmptyCatExprOn :: Sql DBType a
+  => (i -> Expr (NonEmpty a)) -> Aggregator1 i (Expr (NonEmpty a))
+nonEmptyCatExprOn f = lmap f nonEmptyCatExpr
+
+
 -- | 'distinctAggregate' modifies an 'Aggregator' to consider only distinct
 -- values of a particular column.
 distinctAggregate :: Sql DBEq a
@@ -295,6 +326,27 @@ snonEmptyAggExpr info =
     Opaleye.arrayAgg
 
 
+slistCatExpr :: ()
+  => TypeInformation (Unnullify a) -> Aggregator' fold (Expr [a]) (Expr [a])
+slistCatExpr info = dimap (unbracket . show) (sread name . bracket) agg
+  where
+    bracket a = "{" <> a <> "}"
+    unbracket a = Text.substr a 2 (Just (Text.length a - 2))
+    agg = filterWhereExplicit ifPP (/=. "") (stringAgg ",")
+    name = arrayTypeName info
+
+
+snonEmptyCatExpr :: ()
+  => TypeInformation (Unnullify a)
+  -> Aggregator1 (Expr (NonEmpty a)) (Expr (NonEmpty a))
+snonEmptyCatExpr info = dimap (unbracket . show) (sread name . bracket) agg
+  where
+    bracket a = "{" <> a <> "}"
+    unbracket a = Text.substr a 2 (Just (Text.length a - 2))
+    agg = filterWhereExplicit ifPP (/=. "") (stringAgg ",")
+    name = arrayTypeName info
+
+
 ifPP :: Opaleye.IfPP (Expr a) (Expr a)
 ifPP = dimap from to Opaleye.ifPPField
   where

src/Rel8/Expr/Opaleye.hs

@@ -1,6 +1,7 @@
 {-# language FlexibleContexts #-}
 {-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
+{-# language TypeApplications #-}
 {-# language TypeFamilies #-}
 
 {-# options_ghc -fno-warn-redundant-constraints #-}
@@ -26,7 +27,7 @@ import {-# SOURCE #-} Rel8.Expr ( Expr( Expr ) )
 import Rel8.Schema.Null ( Unnullify, Sql )
 import Rel8.Type ( DBType, typeInformation )
 import Rel8.Type.Information ( TypeInformation(..) )
-import Rel8.Type.Name (showTypeName)
+import Rel8.Type.Name (TypeName, showTypeName)
 
 -- profunctors
 import Data.Profunctor ( Profunctor, dimap )
@@ -38,18 +39,19 @@ castExpr = scastExpr typeInformation
 
 -- | Cast an expression to a different type. Corresponds to a @CAST()@ function
 -- call.
-unsafeCastExpr :: Sql DBType b => Expr a -> Expr b
-unsafeCastExpr = sunsafeCastExpr typeInformation
+unsafeCastExpr :: forall b a. Sql DBType b => Expr a -> Expr b
+unsafeCastExpr = case typeInformation @(Unnullify b) of
+  TypeInformation {typeName} -> sunsafeCastExpr typeName
 
 
 scastExpr :: TypeInformation (Unnullify a) -> Expr a -> Expr a
-scastExpr = sunsafeCastExpr
+scastExpr TypeInformation {typeName} = sunsafeCastExpr typeName
 
 
 sunsafeCastExpr :: ()
-  => TypeInformation (Unnullify b) -> Expr a -> Expr b
-sunsafeCastExpr TypeInformation {typeName} =
-  fromPrimExpr . Opaleye.CastExpr (showTypeName typeName) . toPrimExpr
+  => TypeName -> Expr a -> Expr b
+sunsafeCastExpr name =
+  fromPrimExpr . Opaleye.CastExpr (showTypeName name) . toPrimExpr
 
 
 -- | Unsafely construct an expression from literal SQL.

src/Rel8/Expr/Read.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
+
+module Rel8.Expr.Read
+  ( read
+  , sread
+  )
+where
+
+-- base
+import Prelude ()
+
+-- rel8
+import Rel8.Expr (Expr)
+import Rel8.Expr.Opaleye (unsafeCastExpr, sunsafeCastExpr)
+import Rel8.Schema.Null (Sql)
+import Rel8.Type (DBType)
+import Rel8.Type.Name (TypeName)
+
+-- text
+import Data.Text (Text)
+
+
+read :: Sql DBType a => Expr Text -> Expr a
+read = unsafeCastExpr
+
+
+sread :: TypeName -> Expr Text -> Expr a
+sread = sunsafeCastExpr

src/Rel8/Expr/Show.hs

@@ -0,0 +1,18 @@
+module Rel8.Expr.Show
+  ( show
+  )
+where
+
+-- base
+import Prelude ()
+
+-- rel8
+import Rel8.Expr (Expr)
+import Rel8.Expr.Opaleye (unsafeCastExpr)
+
+-- text
+import Data.Text (Text)
+
+
+show :: Expr a -> Expr Text
+show = unsafeCastExpr

src/Rel8/Schema/HTable.hs

@@ -135,23 +135,29 @@ htabulateA :: (HTable t, Apply m)
 htabulateA f = htraverse getCompose $ htabulate $ Compose . f
 {-# INLINABLE htabulateA #-}
 
+
 newtype ApplyP p a b = ApplyP { unApplyP :: p a b }
 
+
 instance Profunctor p => Functor (ApplyP p a) where
   fmap f = ApplyP . rmap f . unApplyP
 
+
 instance ProductProfunctor p => Apply (ApplyP p a) where
   ApplyP f <.> ApplyP x = ApplyP (rmap id f **** x)
 
+
 htraverseP :: (HTable t, ProductProfunctor p)
   => (forall a. p (f a) (g a)) -> p (t f) (t g)
 htraverseP f = htraversePWithField (const f)
 
+
 htraversePWithField :: (HTable t, ProductProfunctor p)
   => (forall a. HField t a -> p (f a) (g a)) -> p (t f) (t g)
 htraversePWithField f = unApplyP $ htabulateA $ \field -> ApplyP $
   lmap (flip hfield field) (f field)
 
+
 type GHField :: K.HTable -> Type -> Type
 newtype GHField t a = GHField (HField (GHColumns (Rep (t Proxy))) a)
 

src/Rel8/Schema/HTable/Vectorize.hs

@@ -25,6 +25,7 @@ module Rel8.Schema.HTable.Vectorize
   , hnullify
   , happend, hempty
   , hproject
+  , htraverseVectorP
   , hcolumn
   , First (..)
   )
@@ -37,12 +38,19 @@ import qualified Data.Semigroup as Base
 import GHC.Generics (Generic)
 import Prelude
 
+-- product-profunctors
+import Data.Profunctor.Product (ProductProfunctor)
+
+-- profunctors
+import Data.Profunctor (dimap)
+
 -- rel8
 import Rel8.FCF ( Eval, Exp )
 import Rel8.Schema.Dict ( Dict( Dict ) )
 import qualified Rel8.Schema.Kind as K
 import Rel8.Schema.HTable
   ( HField, HTable, hfield, htabulate, htabulateA, hspecs
+  , htraversePWithField
   )
 import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
 import Rel8.Schema.HTable.MapTable
@@ -161,6 +169,15 @@ hproject :: ()
 hproject f (HVectorize a) = HVectorize (HMapTable.hproject f a)
 
 
+htraverseVectorP :: (HTable t, ProductProfunctor p)
+  => (forall a. HField t a -> p (f (list a)) (g (list' a)))
+  -> p (HVectorize list t f) (HVectorize list' t g)
+htraverseVectorP f =
+  dimap (\(HVectorize (HMapTable a)) -> a) (HVectorize . HMapTable) $
+    htraversePWithField $ \field ->
+      dimap (\(Precompose a) -> a) Precompose (f field)
+
+
 hcolumn :: HVectorize list (HIdentity a) context -> context (list a)
 hcolumn (HVectorize (HMapTable (HIdentity (Precompose a)))) = a