Eliminate the need for Array1D (i.e., unify with [])

To implement the `DBType` instance for `[]`, we wrapped the underlying Postgres array with `ROW()`. This is to allow nesting `[]` inside `[]` (Postgres treats a bare `foo[][]` as a multidimensional array).

However, instead of unconditionally wrapping the list itself with `ROW()`, we could instead wrap individual list elements. And even better, we can wrap them *conditionally*, i.e., only if they have an array type (e.g., `foo[]`). This makes our lists much closer to Postgres arrays, and eliminates the need for `Array1D`. It also means our lists can be concatenated with a bare `||` operator; no need for the flaky `(foo).f1` unwrapping step.

rel8.cabal

@@ -168,7 +168,6 @@ library
 
     Rel8.Type
     Rel8.Type.Array
-    Rel8.Type.Array1D
     Rel8.Type.Composite
     Rel8.Type.Eq
     Rel8.Type.Enum

src/Rel8.hs

@@ -218,7 +218,6 @@ module Rel8
   , countRows
   , groupBy
   , headAgg
-  , array1DAggExpr
   , listAgg, listAggExpr
   , nonEmptyAgg, nonEmptyAggExpr
   , DBMax, max
@@ -272,8 +271,6 @@ module Rel8
     -- TODO
     -- These need organizing, but are reachable from Rel8's documentation so we
     -- do need to export and document them.
-  , Array1D( Array1D )
-  , NotArray
   , Nullable
   , NotNull
   , HTable
@@ -358,7 +355,6 @@ import Rel8.Table.Rel8able ()
 import Rel8.Table.Serialize
 import Rel8.Table.These
 import Rel8.Type
-import Rel8.Type.Array1D
 import Rel8.Type.Composite
 import Rel8.Type.Eq
 import Rel8.Type.Enum

src/Rel8/Aggregate/Legacy.hs

@@ -1,6 +1,7 @@
 {-# language AllowAmbiguousTypes #-}
 {-# language DataKinds #-}
 {-# language FlexibleContexts #-}
+{-# language NamedFieldPuns #-}
 {-# language RankNTypes #-}
 {-# language ScopedTypeVariables #-}
 {-# language StandaloneKindSignatures #-}
@@ -37,7 +38,8 @@ import Rel8.Expr ( Col( E ), Expr )
 import Rel8.Expr.Aggregate
   ( groupByExpr
   , headAggExpr
-  , listAggExpr, nonEmptyAggExpr
+  , slistAggExpr
+  , snonEmptyAggExpr
   )
 import Rel8.Generic.Construction ( GGAggregate', ggaggregate' )
 import Rel8.Generic.Table ( GAlgebra )
@@ -48,6 +50,7 @@ import Rel8.Schema.Dict ( Dict( Dict ) )
 import Rel8.Schema.HTable ( hmap, hfield, htabulate )
 import Rel8.Schema.HTable.Vectorize ( hvectorize )
 import Rel8.Schema.Kind ( Rel8able )
+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
 import Rel8.Table ( toColumns, fromColumns )
 import Rel8.Table.ADT ( ConstructableADT, ADT( ADT ), ADTRep )
 import Rel8.Table.Eq ( EqTable, eqTable )
@@ -105,7 +108,7 @@ headAgg = fromColumns . hmap (\(E a) -> A $ headAggExpr a) . toColumns
 listAgg :: Aggregates aggregates exprs => exprs -> ListTable aggregates
 listAgg (toColumns -> exprs) = fromColumns $
   hvectorize
-    (\_ (Identity (E a)) -> A $ listAggExpr a)
+    (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)
     (pure exprs)
 
 
@@ -113,7 +116,7 @@ listAgg (toColumns -> exprs) = fromColumns $
 nonEmptyAgg :: Aggregates aggregates exprs => exprs -> NonEmptyTable aggregates
 nonEmptyAgg (toColumns -> exprs) = fromColumns $
   hvectorize
-    (\_ (Identity (E a)) -> A $ nonEmptyAggExpr a)
+    (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)
     (pure exprs)
 
 

src/Rel8/Expr/Aggregate.hs

@@ -13,7 +13,8 @@ module Rel8.Expr.Aggregate
   , stringAgg
   , groupByExpr
   , headAggExpr
-  , array1DAggExpr, listAggExpr, nonEmptyAggExpr
+  , listAggExpr, nonEmptyAggExpr
+  , slistAggExpr, snonEmptyAggExpr
   )
 where
 
@@ -37,10 +38,11 @@ import Rel8.Expr.Opaleye
   )
 import Rel8.Expr.Null ( null )
 import Rel8.Expr.Serialize ( litExpr )
-import Rel8.Schema.Null ( Sql )
-import Rel8.Type.Array ( fromPrimArray )
-import Rel8.Type.Array1D ( Array1D, NotArray )
+import Rel8.Schema.Null ( Sql, Unnullify )
+import Rel8.Type ( DBType, typeInformation )
+import Rel8.Type.Array ( wrap )
 import Rel8.Type.Eq ( DBEq )
+import Rel8.Type.Information ( TypeInformation )
 import Rel8.Type.Num ( DBNum )
 import Rel8.Type.Ord ( DBMax, DBMin )
 import Rel8.Type.String ( DBString )
@@ -168,35 +170,35 @@ headAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
         one = Opaleye.ConstExpr (Opaleye.NumericLit 1)
 
 
--- | Collect expressions values as an array.
-array1DAggExpr :: NotArray a => Expr a -> Aggregate (Expr (Array1D a))
-array1DAggExpr = unsafeMakeAggregate toPrimExpr fromPrimExpr $ Just
-  Aggregator
-    { operation = Opaleye.AggrArr
-    , ordering = []
-    , distinction = Opaleye.AggrAll
-    }
-
-
 -- | Collect expressions values as a list.
-listAggExpr :: Expr a -> Aggregate (Expr [a])
-listAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
-  Aggregator
-    { operation = Opaleye.AggrArr
-    , ordering = []
-    , distinction = Opaleye.AggrAll
-    }
-  where
-    from = fromPrimExpr . fromPrimArray
+listAggExpr :: Sql DBType a => Expr a -> Aggregate (Expr [a])
+listAggExpr = slistAggExpr typeInformation
 
 
 -- | Collect expressions values as a non-empty list.
-nonEmptyAggExpr :: Expr a -> Aggregate (Expr (NonEmpty a))
-nonEmptyAggExpr = unsafeMakeAggregate toPrimExpr from $ Just
+nonEmptyAggExpr :: Sql DBType a => Expr a -> Aggregate (Expr (NonEmpty a))
+nonEmptyAggExpr = snonEmptyAggExpr typeInformation
+
+
+slistAggExpr :: ()
+  => TypeInformation (Unnullify a) -> Expr a -> Aggregate (Expr [a])
+slistAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
   Aggregator
     { operation = Opaleye.AggrArr
     , ordering = []
     , distinction = Opaleye.AggrAll
     }
   where
-    from = fromPrimExpr . fromPrimArray
+    to = wrap info . toPrimExpr
+
+
+snonEmptyAggExpr :: ()
+  => TypeInformation (Unnullify a) -> Expr a -> Aggregate (Expr (NonEmpty a))
+snonEmptyAggExpr info = unsafeMakeAggregate to fromPrimExpr $ Just
+  Aggregator
+    { operation = Opaleye.AggrArr
+    , ordering = []
+    , distinction = Opaleye.AggrAll
+    }
+  where
+    to = wrap info . toPrimExpr

src/Rel8/Expr/Array.hs

@@ -25,21 +25,21 @@ import Rel8.Expr.Opaleye
   , zipPrimExprsWith
   )
 import Rel8.Type ( DBType, typeInformation )
-import Rel8.Type.Array ( array, zipPrimArraysWith )
+import Rel8.Type.Array ( array )
 import Rel8.Type.Information ( TypeInformation(..) )
-import Rel8.Schema.Null ( Unnullify, Nullity, Sql )
+import Rel8.Schema.Null ( Unnullify, Sql )
 
 
 sappend :: Expr [a] -> Expr [a] -> Expr [a]
-sappend = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
+sappend = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
 
 
 sappend1 :: Expr (NonEmpty a) -> Expr (NonEmpty a) -> Expr (NonEmpty a)
-sappend1 = zipPrimExprsWith (zipPrimArraysWith (Opaleye.BinExpr (Opaleye.:||)))
+sappend1 = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
 
 
-sempty :: Nullity a -> TypeInformation (Unnullify a) -> Expr [a]
-sempty _ info = fromPrimExpr $ array info []
+sempty :: TypeInformation (Unnullify a) -> Expr [a]
+sempty info = fromPrimExpr $ array info []
 
 
 slistOf :: TypeInformation (Unnullify a) -> [Expr a] -> Expr [a]

src/Rel8/Expr/Text.hs

@@ -32,7 +32,6 @@ import Data.ByteString ( ByteString )
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Function ( binaryOperator, function, nullaryFunction )
-import Rel8.Type.Array1D ( Array1D )
 
 -- text
 import Data.Text (Text)
@@ -218,7 +217,7 @@ regexpReplace a b c Nothing = function "regexp_replace" a b c
 
 -- | Corresponds to the @regexp_split_to_array@ function.
 regexpSplitToArray :: ()
-  => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr (Array1D Text)
+  => Expr Text -> Expr Text -> Maybe (Expr Text) -> Expr [Text]
 regexpSplitToArray a b (Just c) = function "regexp_split_to_array" a b c
 regexpSplitToArray a b Nothing = function "regexp_split_to_array" a b
 

src/Rel8/Query/List.hs

@@ -55,5 +55,5 @@ manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr
 
 
 -- | A version of 'many' specialised to single expressions.
-someExpr :: Query (Expr a) -> Query (Expr (NonEmpty a))
+someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))
 someExpr = aggregate . fmap nonEmptyAggExpr

src/Rel8/Table/Aggregate.hs

@@ -1,4 +1,5 @@
 {-# language FlexibleContexts #-}
+{-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
 {-# language TypeApplications #-}
 {-# language TypeFamilies #-}
@@ -21,12 +22,13 @@ import Rel8.Expr ( Expr, Col( E ) )
 import Rel8.Expr.Aggregate
   ( groupByExpr
   , headAggExpr
-  , listAggExpr
-  , nonEmptyAggExpr
+  , slistAggExpr
+  , snonEmptyAggExpr
   )
 import Rel8.Schema.Dict ( Dict( Dict ) )
 import Rel8.Schema.HTable ( hfield, hmap, htabulate )
 import Rel8.Schema.HTable.Vectorize ( hvectorize )
+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )
 import Rel8.Table ( Table, toColumns, fromColumns )
 import Rel8.Table.Eq ( EqTable, eqTable )
 import Rel8.Table.List ( ListTable )
@@ -66,7 +68,7 @@ headAgg = fromColumns . hmap (\(E a) -> A $ headAggExpr a) . toColumns
 listAgg :: Table Expr a => a -> Aggregate (ListTable a)
 listAgg (toColumns -> exprs) = fromColumns $
   hvectorize
-    (\_ (Identity (E a)) -> A $ listAggExpr a)
+    (\SSpec {info} (Identity (E a)) -> A $ slistAggExpr info a)
     (pure exprs)
 
 
@@ -74,5 +76,5 @@ listAgg (toColumns -> exprs) = fromColumns $
 nonEmptyAgg :: Table Expr a => a -> Aggregate (NonEmptyTable a)
 nonEmptyAgg (toColumns -> exprs) = fromColumns $
   hvectorize
-    (\_ (Identity (E a)) -> A $ nonEmptyAggExpr a)
+    (\SSpec {info} (Identity (E a)) -> A $ snonEmptyAggExpr info a)
     (pure exprs)

src/Rel8/Table/List.hs

@@ -116,8 +116,7 @@ instance Table Expr a => Semigroup (ListTable a) where
 
 
 instance Table Expr a => Monoid (ListTable a) where
-  mempty = ListTable $ hempty $ \nullability info ->
-    E (sempty nullability info)
+  mempty = ListTable $ hempty $ \_ -> E . sempty
 
 
 listTable :: Table Expr a => [a] -> ListTable a

src/Rel8/Type/Array.hs

@@ -1,12 +1,13 @@
 {-# language GADTs #-}
+{-# language LambdaCase #-}
 {-# language NamedFieldPuns #-}
 {-# language OverloadedStrings #-}
+{-# language ViewPatterns #-}
 
 module Rel8.Type.Array
-  ( array
+  ( array, wrap
   , listTypeInformation
   , nonEmptyTypeInformation
-  , fromPrimArray, toPrimArray, zipPrimArraysWith
   )
 where
 
@@ -28,10 +29,9 @@ import Rel8.Type.Information ( TypeInformation(..), parseTypeInformation )
 
 array :: Foldable f
   => TypeInformation a -> f Opaleye.PrimExpr -> Opaleye.PrimExpr
-array TypeInformation {typeName} =
-  fromPrimArray .
-  Opaleye.CastExpr (typeName <> "[]") .
-  Opaleye.ArrayExpr . toList
+array info =
+  Opaleye.CastExpr (arrayType info <> "[]") .
+  Opaleye.ArrayExpr . map (wrap info) . toList
 {-# INLINABLE array #-}
 
 
@@ -39,19 +39,17 @@ listTypeInformation :: ()
   => Nullity a
   -> TypeInformation (Unnullify a)
   -> TypeInformation [a]
-listTypeInformation nullity info =
-  case info of
-    TypeInformation{ encode, decode } -> TypeInformation
-      { decode = row $ case nullity of
-          Null -> Hasql.listArray (Hasql.nullable decode)
-          NotNull -> Hasql.listArray (Hasql.nonNullable decode)
-      , encode = case nullity of
-          Null -> array info . fmap (maybe null encode)
-          NotNull -> array info . fmap encode
-      , typeName = "record"
-      }
+listTypeInformation nullity info@TypeInformation {encode, decode} =
+  TypeInformation
+    { decode = case nullity of
+        Null -> Hasql.listArray (Hasql.nullable (unwrap info decode))
+        NotNull -> Hasql.listArray (Hasql.nonNullable (unwrap info decode))
+    , encode = case nullity of
+        Null -> Opaleye.ArrayExpr . fmap (wrap info . maybe null encode)
+        NotNull -> Opaleye.ArrayExpr . fmap (wrap info . encode)
+    , typeName = arrayType info <> "[]"
+    }
   where
-    row = Hasql.composite . Hasql.field . Hasql.nonNullable
     null = Opaleye.ConstExpr Opaleye.NullLit
 
 
@@ -66,15 +64,25 @@ nonEmptyTypeInformation nullity =
     message = "failed to decode NonEmptyList: got empty list"
 
 
-fromPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
-fromPrimArray = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
+isArray :: TypeInformation a -> Bool
+isArray = \case
+  (reverse . typeName -> ']' : '[' : _) -> True
+  _ -> False
 
 
-toPrimArray :: Opaleye.PrimExpr -> Opaleye.PrimExpr
-toPrimArray a = Opaleye.CompositeExpr a "f1"
+arrayType :: TypeInformation a -> String
+arrayType info
+  | isArray info = "record"
+  | otherwise = typeName info
 
 
-zipPrimArraysWith :: ()
-  => (Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr)
-  -> Opaleye.PrimExpr -> Opaleye.PrimExpr -> Opaleye.PrimExpr
-zipPrimArraysWith f a b = fromPrimArray (f (toPrimArray a) (toPrimArray b))
+wrap :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr
+wrap info
+  | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")
+  | otherwise = id
+
+
+unwrap :: TypeInformation a -> Hasql.Value x -> Hasql.Value x
+unwrap info
+  | isArray info = Hasql.composite . Hasql.field . Hasql.nonNullable
+  | otherwise = id

src/Rel8/Type/Array1D.hs

@@ -1,139 +0,0 @@
-{-# language DataKinds #-}
-{-# language DeriveTraversable #-}
-{-# language DerivingStrategies #-}
-{-# language FlexibleContexts #-}
-{-# language FlexibleInstances #-}
-{-# language GeneralizedNewtypeDeriving #-}
-{-# language NamedFieldPuns #-}
-{-# language StandaloneKindSignatures #-}
-{-# language TypeFamilies #-}
-{-# language UndecidableInstances #-}
-
-{-# options_ghc -fno-warn-redundant-constraints #-}
-
-module Rel8.Type.Array1D
-  ( Array1D( Array1D )
-  , NotArray
-  , getArray1D
-  )
-where
-
--- aeson
-import Data.Aeson
-  ( ToJSON
-  , ToJSON1
-  , ToJSONKey
-  , FromJSON
-  , FromJSON1
-  , FromJSONKey
-  )
-
--- base
-import Control.Applicative ( Alternative, (<|>) )
-import Control.Monad ( MonadPlus )
-import Data.Functor.Classes ( Eq1, Ord1, Read1, Show1 )
-import Data.Kind ( Type )
-import GHC.Exts ( IsList )
-import Prelude hiding ( null )
-
--- hasql
-import qualified Hasql.Decoders as Hasql
-
--- opaleye
-import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
-
--- rel8
-import Rel8.Expr.Opaleye ( zipPrimExprsWith )
-import Rel8.Expr.Serialize ( litExpr )
-import Rel8.Schema.Null ( Unnullify, Nullity( Null, NotNull ), Sql, nullable )
-import Rel8.Type ( DBType, typeInformation )
-import Rel8.Type.Eq ( DBEq )
-import Rel8.Type.Information ( TypeInformation(..) )
-import Rel8.Type.Monoid ( DBMonoid, memptyExpr )
-import Rel8.Type.Ord ( DBMax, DBMin, DBOrd )
-import Rel8.Type.Semigroup ( DBSemigroup, (<>.) )
-
--- semigroupoids
-import Data.Functor.Alt ( Alt, (<!>) )
-import Data.Functor.Apply ( Apply )
-import Data.Functor.Bind ( Bind )
-import Data.Functor.Plus ( Plus )
-
--- semialign
-import Data.Align ( Align )
-import Data.Semialign ( Semialign )
-import Data.Zip ( Repeat, Unzip, Zip )
-
-
--- | A one dimensional array.
-newtype Array1D a = Array1D [a]
-  deriving stock Traversable
-  deriving newtype
-    ( Eq, Ord, Read, Show, Semigroup, Monoid, IsList
-    , Functor, Foldable
-    , Eq1, Ord1, Read1, Show1
-    , FromJSON1, ToJSON1, FromJSON, FromJSONKey, ToJSON, ToJSONKey
-    , Apply, Applicative, Alternative, Plus, Bind, Monad, MonadPlus
-    , Align, Semialign, Repeat, Unzip, Zip
-    )
-
-
-instance Alt Array1D where
-  (<!>) = (<|>)
-
-
-getArray1D :: Array1D a -> [a]
-getArray1D (Array1D a) = a
-
-
-type IsArray1D :: Type -> Bool
-type family IsArray1D a where
-  IsArray1D (Array1D _) = 'True
-  IsArray1D _ = 'False
-
-
-class IsArray1D a ~ 'False => NotArray a
-instance IsArray1D a ~ 'False => NotArray a
-
-
-array1DTypeInformation :: Sql NotArray a
-  => Nullity a
-  -> TypeInformation (Unnullify a)
-  -> TypeInformation (Array1D a)
-array1DTypeInformation nullity info =
-  case info of
-    TypeInformation{ encode, decode, typeName } -> TypeInformation
-      { decode = case nullity of
-          Null -> Array1D <$> Hasql.listArray (Hasql.nullable decode)
-          NotNull -> Array1D <$> Hasql.listArray (Hasql.nonNullable decode)
-      , encode = case nullity of
-          Null -> Opaleye.ArrayExpr . fmap (maybe null encode) . getArray1D
-          NotNull -> Opaleye.ArrayExpr . fmap encode . getArray1D
-      , typeName = typeName <> "[]"
-      }
-  where
-    null = Opaleye.ConstExpr Opaleye.NullLit
-
-
-instance (Sql DBType a, Sql NotArray a) => DBType (Array1D a) where
-  typeInformation = array1DTypeInformation nullable typeInformation
-
-
-instance (Sql DBEq a, Sql NotArray a) => DBEq (Array1D a)
-
-
-instance (Sql DBOrd a, Sql NotArray a) => DBOrd (Array1D a)
-
-
-instance (Sql DBMax a, Sql NotArray a) => DBMax (Array1D a)
-
-
-instance (Sql DBMin a, Sql NotArray a) => DBMin (Array1D a)
-
-
-instance (Sql DBType a, Sql NotArray a) => DBSemigroup (Array1D a) where
-  (<>.) = zipPrimExprsWith (Opaleye.BinExpr (Opaleye.:||))
-
-
-instance (Sql DBType a, Sql NotArray a) => DBMonoid (Array1D a) where
-  memptyExpr = litExpr mempty

src/Rel8/Type/Monoid.hs

@@ -27,7 +27,7 @@ import Data.CaseInsensitive ( CI )
 import {-# SOURCE #-} Rel8.Expr ( Expr )
 import Rel8.Expr.Array ( sempty )
 import Rel8.Expr.Serialize ( litExpr )
-import Rel8.Schema.Null ( Sql, nullable )
+import Rel8.Schema.Null ( Sql )
 import Rel8.Type ( DBType, typeInformation )
 import Rel8.Type.Semigroup ( DBSemigroup )
 
@@ -48,7 +48,7 @@ class DBSemigroup a => DBMonoid a where
 
 
 instance Sql DBType a => DBMonoid [a] where
-  memptyExpr = sempty nullable typeInformation
+  memptyExpr = sempty typeInformation
 
 
 instance DBMonoid CalendarDiffTime where

src/Rel8/Type/Semigroup.hs

@@ -13,10 +13,9 @@ module Rel8.Type.Semigroup
 where
 
 -- base
-import Data.Function ( on )
 import Data.Kind ( Constraint, Type )
 import Data.List.NonEmpty ( NonEmpty )
-import Prelude
+import Prelude ()
 
 -- bytestring
 import Data.ByteString ( ByteString )
@@ -30,10 +29,10 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
 -- rel8
 import {-# SOURCE #-} Rel8.Expr ( Expr )
+import Rel8.Expr.Array ( sappend, sappend1 )
 import Rel8.Expr.Opaleye ( zipPrimExprsWith )
 import Rel8.Schema.Null ( Sql )
 import Rel8.Type ( DBType )
-import Rel8.Type.Array ( fromPrimArray, toPrimArray )
 
 -- text
 import Data.Text ( Text )
@@ -53,13 +52,11 @@ class DBType a => DBSemigroup a where
 
 
 instance Sql DBType a => DBSemigroup [a] where
-  (<>.) = zipPrimExprsWith do
-    (fromPrimArray .) . Opaleye.BinExpr (Opaleye.:||) `on` toPrimArray
+  (<>.) = sappend
 
 
 instance Sql DBType a => DBSemigroup (NonEmpty a) where
-  (<>.) = zipPrimExprsWith do
-    (fromPrimArray .) . Opaleye.BinExpr (Opaleye.:||) `on` toPrimArray
+  (<>.) = sappend1
 
 
 instance DBSemigroup CalendarDiffTime where