0272bcc · rel8 · git.iko.soy

git.iko.soy/rel8

Fix aggregateMaybeTable and friends (#127)

None of these functions actually worked (they would generate invalid SQL that referenced the inner tag column where it was no longer in scope). The root of the problem was in the Nullifiable instance for the Aggregate context. The new version works, at the cost of grouping by the tag `n + 1` times instead of just once (where `n` is the number of columns in the `MaybeTable`).

commit0272bcc8ea50335dc432140eade6dfbe0efdf654 authorShane <shane.obrien@circuithub.com> dateFri 22 Oct 2021, 14:14 (5 years ago) parent379b492

3 files changed+38−38

compare with master

unifiedsplit

src/Rel8/Aggregate.hs+8−24 src/Rel8/Schema/Context/Nullify.hs+6−14 tests/Main.hs+24

src/Rel8/Aggregate.hs+8−24

@@ -9,14 +9,14 @@

99{-# language UndecidableInstances #-}

1010

1111module Rel8.Aggregate

12− ( Aggregate(..), foldInputs, mapInputs

12+ ( Aggregate(..), zipOutputs

1313 , Aggregator(..), unsafeMakeAggregate

1414 , Aggregates

1515 )

1616where

1717

1818-- base

19−import Data.Functor.Const ( Const( Const ), getConst )

19+import Control.Applicative ( liftA2 )

2020import Data.Functor.Identity ( Identity( Identity ) )

2121import Data.Kind ( Constraint, Type )

2222import Prelude

@@ -40,11 +40,7 @@ import Rel8.Table.Transpose ( Transposes )

4040import Rel8.Type ( DBType )

4141

4242

43−-- | An @Aggregate a@ describes how to aggregate @Table@s of type @a@. You can

44−-- unpack an @Aggregate@ back to @a@ by running it with 'Rel8.aggregate'. As

45−-- @Aggregate@ is almost an 'Applicative' functor - but there is no 'pure'

46−-- operation. This means 'Aggregate' is an instance of 'Apply', and you can

47−-- combine @Aggregate@s using the @<.>@ combinator.

43+-- | 'Aggregate' is a special context used by 'Rel8.aggregate'.

4844type Aggregate :: K.Context

4945newtype Aggregate a = Aggregate (Opaleye.Aggregator () (Expr a))

5046

@@ -61,28 +57,16 @@ instance Sql DBType a => Table Aggregate (Aggregate a) where

6157 fromResult (HIdentity (Identity a)) = a

6258

6359

64−-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate' 'Expr's

65−-- for the columns in @b@.

60+-- | @Aggregates a b@ means that the columns in @a@ are all 'Aggregate's

61+-- for the 'Expr' columns in @b@.

6662type Aggregates :: Type -> Type -> Constraint

6763class Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

6864instance Transposes Aggregate Expr aggregates exprs => Aggregates aggregates exprs

6965

7066

71−foldInputs :: forall (a :: Type) (b :: Type). Monoid b

72− => (Maybe Aggregator -> Opaleye.PrimExpr -> b) -> Aggregate a -> b

73−foldInputs f (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

74− getConst $ flip agg () $ \(aggregator, a) ->

75− Const $ f (detuplize <$> aggregator) a

76− where

77− detuplize (operation, ordering, distinction) =

78− Aggregator {operation, ordering, distinction}

79−

80−

81−mapInputs :: forall (a :: Type). ()

82− => (Opaleye.PrimExpr -> Opaleye.PrimExpr) -> Aggregate a -> Aggregate a

83−mapInputs transform (Aggregate (Opaleye.Aggregator (Opaleye.PackMap agg))) =

84− Aggregate $ Opaleye.Aggregator $ Opaleye.PackMap $ agg . \f input ->

85− f (fmap transform input)

67+zipOutputs :: ()

68+ => (Expr a -> Expr b -> Expr c) -> Aggregate a -> Aggregate b -> Aggregate c

69+zipOutputs f (Aggregate a) (Aggregate b) = Aggregate (liftA2 f a b)

8670

8771

8872type Aggregator :: Type

src/Rel8/Schema/Context/Nullify.hs+6−14

@@ -18,18 +18,17 @@ where

1818import Data.Bool ( bool )

1919import Data.Functor.Identity ( Identity( Identity ) )

2020import Data.Kind ( Constraint, Type )

21−import Data.Monoid ( getFirst )

2221import Prelude hiding ( null )

2322

2423-- opaleye

2524import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye

2625

2726-- rel8

28−import Rel8.Aggregate ( Aggregate( Aggregate ), foldInputs, mapInputs )

27+import Rel8.Aggregate ( Aggregate(..), zipOutputs )

2928import Rel8.Expr ( Expr )

3029import Rel8.Expr.Bool ( boolExpr )

3130import Rel8.Expr.Null ( nullify, unsafeUnnullify )

32−import Rel8.Expr.Opaleye ( fromPrimExpr, toPrimExpr )

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

3332import Rel8.Kind.Context ( SContext(..) )

3433import Rel8.Schema.Field ( Field )

3534import qualified Rel8.Schema.Kind as K

@@ -95,17 +94,10 @@ guarder :: ()

9594 -> context (Maybe a)

9695 -> context (Maybe a)

9796guarder = \case

98− SAggregate -> \tag _ isNonNull (Aggregate a) ->

99− let

100− mtag = foldInputs (\_ -> pure . fromPrimExpr) tag

101− run = maybe id (sguard . isNonNull) (getFirst mtag)

102− in

103− mapInputs (toPrimExpr . run . fromPrimExpr) $

104− Aggregate $

105− run <$> a

106− SExpr -> \tag _ isNonNull a -> sguard (isNonNull tag) a

107− SField -> \_ _ _ field -> field

108− SName -> \_ _ _ name -> name

97+ SAggregate -> \tag _ isNonNull -> zipOutputs (sguard . isNonNull) tag

98+ SExpr -> \tag _ isNonNull -> sguard (isNonNull tag)

99+ SField -> \_ _ _ -> id

100+ SName -> \_ _ _ -> id

109101 SResult -> \(Identity tag) isNonNull _ (Identity a) ->

110102 Identity (bool Nothing a (isNonNull tag))

111103

tests/Main.hs+24

@@ -1,3 +1,4 @@

1+{-# language BangPatterns #-}

12{-# language BlockArguments #-}

23{-# language DeriveAnyClass #-}

34{-# language DeriveGeneric #-}

@@ -113,6 +114,7 @@ tests =

113114 , testCatMaybeTable getTestDatabase

114115 , testCatMaybe getTestDatabase

115116 , testMaybeTable getTestDatabase

117+ , testAggregateMaybeTable getTestDatabase

116118 , testNestedTables getTestDatabase

117119 , testMaybeTableApplicative getTestDatabase

118120 , testLogicalFixities getTestDatabase

@@ -555,6 +557,28 @@ testMaybeTable = databasePropertyTest "maybeTable" \transaction -> evalM do

555557 _ -> sort selected === sort rows

556558

557559

560+testAggregateMaybeTable :: IO TmpPostgres.DB -> TestTree

561+testAggregateMaybeTable = databasePropertyTest "aggregateMaybeTable" \transaction -> evalM do

562+ rows <- forAll $ Gen.list (Range.linear 0 10) (Gen.maybe (Gen.int64 (Range.linear 0 10)))

563+

564+ let

565+ aggregate = go 0 False False

566+ where

567+ go !n nothing _ (Just a : as) = go (n + a) nothing True as

568+ go n _ just (Nothing : as) = go n True just as

569+ go _ False False [] = []

570+ go _ True False [] = [Nothing]

571+ go n False True [] = [Just n]

572+ go n True True [] = [Nothing, Just n]

573+

574+ transaction do

575+ selected <- lift do

576+ statement () $ Rel8.select do

577+ Rel8.aggregate $ Rel8.aggregateMaybeTable Rel8.sum <$> Rel8.values (Rel8.lit <$> rows)

578+

579+ sort selected === aggregate rows

580+

581+

558582data TwoTestTables f =

559583 TwoTestTables

560584 { testTable1 :: TestTable f