Make ListTable an instance of Prelude.Functor

src/Rel8/Query/List.hs

@@ -29,10 +29,10 @@ import Rel8.Query.Maybe ( optional )
 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 ( Table, fromColumns, toColumns )
 import Rel8.Table.Cols ( toCols )
 import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )
-import Rel8.Table.List ( ListTable( ListTable ) )
+import Rel8.Table.List ( ListTable )
 import Rel8.Table.Maybe ( maybeTable )
 import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
 import Rel8.Type ( DBType, typeInformation )
@@ -49,7 +49,7 @@ import Rel8.Type.Information ( TypeInformation )
 -- @Control.Applicative@.
 many :: Table Expr a => Query a -> Query (ListTable Expr a)
 many =
-  fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
+  fmap (maybeTable mempty (fromColumns . toColumns)) .
   optional .
   aggregate .
   fmap (listAgg . toCols)
@@ -85,8 +85,8 @@ someExpr = aggregate . fmap nonEmptyAggExpr
 --
 -- @catListTable@ is an inverse to 'many'.
 catListTable :: Table Expr a => ListTable Expr a -> Query a
-catListTable (ListTable as) = rebind $ fromColumns $ runIdentity $
-  hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as
+catListTable as = rebind $ fromColumns $ runIdentity $
+  hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) (toColumns as)
 
 
 -- | Expand a 'NonEmptyTable' into a 'Query', where each row in the query is an

src/Rel8/Schema/HTable/Vectorize.hs

@@ -19,7 +19,7 @@
 {-# language UndecidableInstances #-}
 
 module Rel8.Schema.HTable.Vectorize
-  ( HVectorize
+  ( HVectorize(..)
   , hvectorize, hunvectorize
   , happend, hempty
   )

src/Rel8/Table/List.hs

@@ -1,6 +1,9 @@
+{-# language BlockArguments #-}
 {-# language DataKinds #-}
 {-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
+{-# language GADTs #-}
+{-# language LambdaCase #-}
 {-# language MultiParamTypeClasses #-}
 {-# language NamedFieldPuns #-}
 {-# language ScopedTypeVariables #-}
@@ -16,21 +19,26 @@ module Rel8.Table.List
 where
 
 -- base
-import Data.Functor.Identity ( Identity( Identity ) )
+import Control.Applicative ( Const(..) )
+import Data.Functor.Identity ( Identity( Identity ), runIdentity )
 import Data.Kind ( Type )
 import Prelude
+import Data.List ( intercalate )
 
 -- rel8
-import Rel8.Expr ( Expr( E, unE ) )
+import Rel8.Aggregate ( Aggregate )
+import Rel8.Expr ( Expr( Expr, E, unE ) )
 import Rel8.Expr.Array ( sappend, sempty, slistOf )
+import Rel8.Expr.Opaleye ( unsafeLiteral, fromPrimExpr, toPrimExpr )
 import Rel8.Schema.Dict ( Dict( Dict ) )
+import qualified Rel8.Schema.Kind as K
+import Rel8.Schema.HTable ( HTable, htabulate, hfield, hspecs, htraverse, hmap )
 import Rel8.Schema.HTable.List ( HListTable )
 import Rel8.Schema.HTable.Vectorize ( happend, hempty, hvectorize, hunvectorize )
-import qualified Rel8.Schema.Kind as K
-import Rel8.Schema.Name ( Name( N, Name ) )
+import Rel8.Schema.Name ( Name( N, Name, unN ) )
 import Rel8.Schema.Null ( Nullity( Null, NotNull ) )
 import Rel8.Schema.Result ( vectorizer, unvectorizer )
-import Rel8.Schema.Spec ( SSpec(..) )
+import Rel8.Schema.Spec ( Spec(..), SSpec(..) )
 import Rel8.Table
   ( Table, Context, Columns, fromColumns, toColumns
   , FromExprs, fromResult, toResult
@@ -42,30 +50,104 @@ import Rel8.Table.Alternative
 import Rel8.Table.Eq ( EqTable, eqTable )
 import Rel8.Table.Ord ( OrdTable, ordTable )
 import Rel8.Table.Recontextualize ( Recontextualize )
+import Control.Monad.Trans.State.Strict ( evalState, get, put, State )
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as O
+import qualified Opaleye.Internal.HaskellDB.Sql.Default as O
+import qualified Opaleye.Internal.HaskellDB.Sql.Print as O
+import qualified Opaleye.Internal.HaskellDB.Sql.Generate as O
 import Rel8.Table.Serialize ( ToExprs )
 
 
 -- | A @ListTable@ value contains zero or more instances of @a@. You construct
 -- @ListTable@s with 'Rel8.many' or 'Rel8.listAgg'.
 type ListTable :: K.Context -> Type -> Type
-newtype ListTable context a =
-  ListTable (HListTable (Columns a) (Context a))
+data ListTable context a where
+  ListTable :: HTable f
+    => (f context -> b)
+    -> HListTable f context
+    -> ListTable context b
+
+
+instance Functor (ListTable i) where
+  fmap f (ListTable g cols) = ListTable (f . g) cols
+
+
+class ListContext context where
+  mapColumns
+    :: (HTable f, HTable g)
+    => (f context -> g context)
+    -> HListTable f context
+    -> HListTable g context
+
+
+instance ListContext Expr where
+  mapColumns f i = hvectorize v $ pure $ htabulate \field ->
+    case hfield hspecs field of
+      SSpec{} ->
+        hfield (f exprs) field
+    where
+      names = evalState (htraverse freshName i) 0
+
+      namesList = getConst $ htraverse g names
+        where
+          g :: forall (a :: Spec). Name a -> Const [String] (Name a)
+          g (N (Name x)) = Const [x]
+
+      v :: SSpec ('Spec a) -> Identity (Expr ('Spec a)) -> Expr ('Spec [a])
+      v SSpec{} (Identity (E (Expr yuck))) =
+        E $ unsafeLiteral $
+        "(SELECT array_agg(" <> show (O.ppSqlExpr (O.sqlExpr O.defaultSqlGenerator yuck)) <> ") FROM " <>
+        "(SELECT " <> unnests <> ") q(" <> intercalate "," namesList <> "))"
+
+      unnests :: String
+      unnests = intercalate "," $ getConst $ htraverse unnest i
+        where
+          unnest :: forall (a :: Spec). Expr a -> Const [String] (Expr a)
+          unnest (E (Expr yuck)) =
+            Const [ "unnest(" <> show (O.ppSqlExpr (O.sqlExpr O.defaultSqlGenerator yuck)) <> ")" ]
+
+      freshName :: forall (a :: Spec). Expr a -> State Int (Name a)
+      freshName (E _) = do
+        n <- get
+        put (n + 1)
+        return $ N $ Name $ "x" <> show n
+
+      exprs = runIdentity $ hunvectorize uv (hmap projectName names)
+        where
+          uv :: SSpec ('Spec a) -> Expr ('Spec [a]) -> Identity (Expr ('Spec a))
+          uv SSpec{} = pure . E . fromPrimExpr . toPrimExpr . unE
+
+          projectName :: forall (a :: Spec). Name a -> Expr a
+          projectName (N (Name name)) =
+            E $ fromPrimExpr $ O.BaseTableAttrExpr name
+
+
+instance ListContext Aggregate where
+  mapColumns f i = undefined
+
+
+instance ListContext Name where
+  mapColumns f =
+    hvectorize (\_ -> rename . runIdentity) .
+    fmap f .
+    hunvectorize (\_ -> pure . rename)
+    where rename = N . (\(Name x) -> Name x) . unN
 
 
-instance (Table context a, context ~ context') =>
+instance (Table context a, context ~ context', ListContext context') =>
   Table context' (ListTable context a)
  where
   type Columns (ListTable context a) = HListTable (Columns a)
   type Context (ListTable context a) = Context a
   type FromExprs (ListTable context a) = [FromExprs a]
 
-  fromColumns = ListTable
-  toColumns (ListTable a) = a
+  fromColumns = ListTable fromColumns
+  toColumns (ListTable f cols) = mapColumns (toColumns . f) cols
   fromResult = fmap (fromResult @_ @a) . hunvectorize unvectorizer
   toResult = hvectorize vectorizer . fmap (toResult @_ @a)
 
 
-instance (Recontextualize from to a b, from ~ from', to ~ to') =>
+instance (Recontextualize from to a b, from ~ from', to ~ to', ListContext from', ListContext to') =>
   Recontextualize from to (ListTable from' a) (ListTable to' b)
 
 
@@ -102,20 +184,20 @@ instance context ~ Expr => AlternativeTable (ListTable context) where
 instance (context ~ Expr, Table Expr a) =>
   Semigroup (ListTable context a)
  where
-  ListTable as <> ListTable bs = ListTable $
-    happend (\_ _ (E a) (E b) -> E (sappend a b)) as bs
+  as <> bs = fromColumns $
+    happend (\_ _ (E a) (E b) -> E (sappend a b)) (toColumns as) (toColumns bs)
 
 
 instance (context ~ Expr, Table Expr a) =>
   Monoid (ListTable context a)
  where
-  mempty = ListTable $ hempty $ \_ -> E . sempty
+  mempty = fromColumns $ hempty $ \_ -> E . sempty
 
 
 -- | Construct a @ListTable@ from a list of expressions.
 listTable :: Table Expr a => [a] -> ListTable Expr a
 listTable =
-  ListTable .
+  fromColumns .
   hvectorize (\SSpec {info} -> E . slistOf info . fmap unE) .
   fmap toColumns
 
@@ -128,7 +210,7 @@ nameListTable
   => a -- ^ The names of the columns of elements of the list.
   -> ListTable Name a
 nameListTable =
-  ListTable .
+  fromColumns .
   hvectorize (\_ (Identity (N (Name a))) -> N (Name a)) .
   pure .
   toColumns