diff --git a/src/Rel8/Query/List.hs b/src/Rel8/Query/List.hs index 45a6a15c..8d786161 100644 --- a/src/Rel8/Query/List.hs +++ b/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 diff --git a/src/Rel8/Schema/HTable/Vectorize.hs b/src/Rel8/Schema/HTable/Vectorize.hs index ccc35912..cba809d0 100644 --- a/src/Rel8/Schema/HTable/Vectorize.hs +++ b/src/Rel8/Schema/HTable/Vectorize.hs @@ -19,7 +19,7 @@ {-# language UndecidableInstances #-} module Rel8.Schema.HTable.Vectorize - ( HVectorize + ( HVectorize(..) , hvectorize, hunvectorize , happend, hempty ) diff --git a/src/Rel8/Table/List.hs b/src/Rel8/Table/List.hs index bea60f96..869d6855 100644 --- a/src/Rel8/Table/List.hs +++ b/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