a3b32bd · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

unnest support

a3b32bdShane O'Brien5 years ago

src/Rel8.hs+4

compare with master

unifiedsplit

@@ -100,6 +100,8 @@ module Rel8

100 , nameListTable

101 , many

102 , manyExpr

103+ , catListTable

104+ , catList

103

105

104 -- ** @NonEmptyTable@

106 -- ** @NonEmptyTable@

105 , NonEmptyTable

107 , NonEmptyTable

@@ -108,6 +110,8 @@ module Rel8

108 , nameNonEmptyTable

110 , nameNonEmptyTable

109 , some

111 , some

110 , someExpr

112 , someExpr

113+ , catNonEmptyTable

114+ , catNonEmpty

111

115

112 -- ** @ADT@

116 -- ** @ADT@

113 , ADT, ADTable, fromADT, toADT

117 , ADT, ADTable, fromADT, toADT

src/Rel8/Query/List.hs+54−18

@@ -1,29 +1,52 @@

1{-# language FlexibleContexts #-}

2−{-# language MonoLocalBinds #-}

2+{-# language GADTs #-}

3+{-# language NamedFieldPuns #-}

4module Rel8.Query.List

5module Rel8.Query.List

5 ( many, some

6 ( many, some

6 , manyExpr, someExpr

7 , manyExpr, someExpr

8+ , catListTable, catNonEmptyTable

9+ , catList, catNonEmpty

7 )

10 )

8where

11where

10-- base

13-- base

14+import Data.Functor.Identity ( runIdentity )

11import Data.List.NonEmpty ( NonEmpty )

15import Data.List.NonEmpty ( NonEmpty )

12import Prelude

16import Prelude

18+-- opaleye

19+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

20+

14-- rel8

21-- rel8

15−import Rel8.Expr ( Expr )

22+import Rel8.Expr ( Col( E, unE ), Expr )

16import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

23import Rel8.Expr.Aggregate ( listAggExpr, nonEmptyAggExpr )

24+import Rel8.Expr.Opaleye ( mapPrimExpr )

17import Rel8.Query ( Query )

25import Rel8.Query ( Query )

18import Rel8.Query.Aggregate ( aggregate )

26import Rel8.Query.Aggregate ( aggregate )

19import Rel8.Query.Maybe ( optional )

27import Rel8.Query.Maybe ( optional )

20−import Rel8.Schema.Null ( Sql )

28+import Rel8.Schema.HTable.Vectorize ( hunvectorize )

29+import Rel8.Schema.Null ( Sql, Unnullify )

30+import Rel8.Schema.Spec ( SSpec( SSpec, info ) )

21−import Rel8.Table ( Table )

31+import Rel8.Table ( Table, fromColumns )

22import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

32import Rel8.Table.Aggregate ( listAgg, nonEmptyAgg )

23−import Rel8.Table.List ( ListTable )

33+import Rel8.Table.List ( ListTable( ListTable ) )

24import Rel8.Table.Maybe ( maybeTable )

34import Rel8.Table.Maybe ( maybeTable )

25−import Rel8.Table.NonEmpty ( NonEmptyTable )

35+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )

26−import Rel8.Type ( DBType )

36+import Rel8.Type ( DBType, typeInformation )

37+import Rel8.Type.Array ( extractArrayElement )

38+import Rel8.Type.Information ( TypeInformation )

39+

40+

41+-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0

42+-- rows, this function will produce a 'Query' that returns one row containing

43+-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will

44+-- return exactly one row, with a @ListTable@ collecting all returned rows.

45+--

46+-- @many@ is analogous to 'Control.Applicative.many' from

47+-- @Control.Applicative@.

48+many :: Table Expr a => Query a -> Query (ListTable a)

49+many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg

29-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

52-- | Aggregate a 'Query' into a 'NonEmptyTable'. If the supplied query returns

@@ -38,17 +61,6 @@ some :: Table Expr a => Query a -> Query (NonEmptyTable a)

38some = aggregate . fmap nonEmptyAgg

61some = aggregate . fmap nonEmptyAgg

41−-- | Aggregate a 'Query' into a 'ListTable'. If the supplied query returns 0

42−-- rows, this function will produce a 'Query' that returns one row containing

43−-- the empty @ListTable@. If the supplied @Query@ does return rows, @many@ will

44−-- return exactly one row, with a @ListTable@ collecting all returned rows.

45−--

46−-- @many@ is analogous to 'Control.Applicative.many' from

47−-- @Control.Applicative@.

48−many :: Table Expr a => Query a -> Query (ListTable a)

49−many = fmap (maybeTable mempty id) . optional . aggregate . fmap listAgg

50−

51−

52-- | A version of 'many' specialised to single expressions.

64-- | A version of 'many' specialised to single expressions.

53manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])

65manyExpr :: Sql DBType a => Query (Expr a) -> Query (Expr [a])

54manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr

66manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr

@@ -57,3 +69,27 @@ manyExpr = fmap (maybeTable mempty id) . optional . aggregate . fmap listAggExpr

57-- | A version of 'many' specialised to single expressions.

69-- | A version of 'many' specialised to single expressions.

58someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))

70someExpr :: Sql DBType a => Query (Expr a) -> Query (Expr (NonEmpty a))

59someExpr = aggregate . fmap nonEmptyAggExpr

71someExpr = aggregate . fmap nonEmptyAggExpr

72+

73+

74+catListTable :: Table Expr a => ListTable a -> Query a

75+catListTable (ListTable as) = pure $ fromColumns $ runIdentity $

76+ hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

77+

78+

79+catNonEmptyTable :: Table Expr a => NonEmptyTable a -> Query a

80+catNonEmptyTable (NonEmptyTable as) = pure $ fromColumns $ runIdentity $

81+ hunvectorize (\SSpec {info} -> pure . E . sunnest info . unE) as

82+

83+

84+catList :: Sql DBType a => Expr [a] -> Query (Expr a)

85+catList = pure . sunnest typeInformation

86+

87+

88+catNonEmpty :: Sql DBType a => Expr (NonEmpty a) -> Query (Expr a)

89+catNonEmpty = pure . sunnest typeInformation

90+

91+

92+sunnest :: TypeInformation (Unnullify a) -> Expr (list a) -> Expr a

93+sunnest info = mapPrimExpr $

94+ extractArrayElement info .

95+ Opaleye.UnExpr (Opaleye.UnOpOther "UNNEST")

src/Rel8/Schema/HTable/Vectorize.hs+2−2

@@ -46,7 +46,7 @@ import Rel8.Type.Array ( listTypeInformation, nonEmptyTypeInformation )

46import Rel8.Type.Information ( TypeInformation )

48-- semialign

49−import Data.Zip ( Unzip, Repeat, Zippy(..) )

49+import Data.Zip ( Unzip, Zip, Zippy(..) )

50import Rel8.FCF

51import Rel8.Schema.HTable.MapTable

52import GHC.Generics (Generic)

@@ -106,7 +106,7 @@ hvectorize vectorizer as = HVectorize $ htabulate $ \(HMapTableField field) ->

106{-# INLINABLE hvectorize #-}

107

108

109−hunvectorize :: (HTable t, Repeat f, Vector list)

109+hunvectorize :: (HTable t, Zip f, Vector list)

110 => (forall labels necessity a. ()

111 => SSpec ('Spec labels necessity a)

112 -> context ('Spec labels 'Required (list a))

src/Rel8/Type/Array.hs+7−1

@@ -5,7 +5,7 @@

5{-# language ViewPatterns #-}

7module Rel8.Type.Array

8− ( array, encodeArrayElement

8+ ( array, encodeArrayElement, extractArrayElement

9 , listTypeInformation

10 , nonEmptyTypeInformation

11 )

@@ -92,3 +92,9 @@ encodeArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr

92encodeArrayElement info

93 | isArray info = Opaleye.UnExpr (Opaleye.UnOpOther "ROW")

94 | otherwise = id

95+

96+

97+extractArrayElement :: TypeInformation a -> Opaleye.PrimExpr -> Opaleye.PrimExpr

98+extractArrayElement info

99+ | isArray info = flip Opaleye.CompositeExpr "f1"

100+ | otherwise = id

tests/Main.hs+7−2

@@ -694,11 +694,16 @@ testSelectArray = databasePropertyTest "Can SELECT Arrays (with aggregation)" \t

694 rows <- forAll $ Gen.list (Range.linear 1 10) Gen.bool

695

696 transaction \connection -> do

697− selected <- liftIO $ Rel8.select connection $ Rel8.aggregate do

697+ selected <- liftIO $ Rel8.select connection do

698− Rel8.listAgg <$> Rel8.values (map Rel8.lit rows)

698+ Rel8.many $ Rel8.values (map Rel8.lit rows)

699

700 selected === [foldMap pure rows]

701

702+ selected' <- liftIO $ Rel8.select connection $ Rel8.catListTable =<< do

703+ Rel8.many $ Rel8.values (map Rel8.lit rows)

704+

705+ selected' === rows

706+

702

707

703data NestedMaybeTable f = NestedMaybeTable

708data NestedMaybeTable f = NestedMaybeTable

704 { nmt1 :: Rel8.Column f Bool

709 { nmt1 :: Rel8.Column f Bool