0272bcc · rel8 · git.iko.soy

git.iko.soy/rel8

on master help sign in

Fix aggregateMaybeTable and friends (#127)

0272bccShane5 years ago

src/Rel8/Aggregate.hs+8−24

compare with master

unifiedsplit

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

9{-# language UndecidableInstances #-}

11module Rel8.Aggregate

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

12+ ( Aggregate(..), zipOutputs

13 , Aggregator(..), unsafeMakeAggregate

14 , Aggregates

15 )

16where

18-- base

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

19+import Control.Applicative ( liftA2 )

20import Data.Functor.Identity ( Identity( Identity ) )

21import Data.Kind ( Constraint, Type )

22import Prelude

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

40import Rel8.Type ( DBType )

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

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

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.

48type Aggregate :: K.Context

44type Aggregate :: K.Context

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

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

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

61 fromResult (HIdentity (Identity a)) = a

57 fromResult (HIdentity (Identity a)) = a

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

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

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

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

66type Aggregates :: Type -> Type -> Constraint

62type Aggregates :: Type -> Type -> Constraint

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

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

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

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

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

67+zipOutputs :: ()

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

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

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

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

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)

88type Aggregator :: Type

72type Aggregator :: Type

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

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

18import Data.Bool ( bool )

19import Data.Functor.Identity ( Identity( Identity ) )

20import Data.Kind ( Constraint, Type )

21−import Data.Monoid ( getFirst )

22import Prelude hiding ( null )

21import Prelude hiding ( null )

24-- opaleye

23-- opaleye

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

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

27-- rel8

26-- rel8

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

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

29import Rel8.Expr ( Expr )

28import Rel8.Expr ( Expr )

30import Rel8.Expr.Bool ( boolExpr )

29import Rel8.Expr.Bool ( boolExpr )

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

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

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

31+import Rel8.Expr.Opaleye ( fromPrimExpr )

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

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

34import Rel8.Schema.Field ( Field )

33import Rel8.Schema.Field ( Field )

35import qualified Rel8.Schema.Kind as K

34import qualified Rel8.Schema.Kind as K

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

95 -> context (Maybe a)

94 -> context (Maybe a)

96 -> context (Maybe a)

95 -> context (Maybe a)

97guarder = \case

96guarder = \case

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

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

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

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

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

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

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

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

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

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

110 Identity (bool Nothing a (isNonNull tag))

102 Identity (bool Nothing a (isNonNull tag))

111

103

tests/Main.hs+24

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

1+{-# language BangPatterns #-}

1{-# language BlockArguments #-}

2{-# language BlockArguments #-}

2{-# language DeriveAnyClass #-}

3{-# language DeriveAnyClass #-}

3{-# language DeriveGeneric #-}

4{-# language DeriveGeneric #-}

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

113 , testCatMaybeTable getTestDatabase

114 , testCatMaybeTable getTestDatabase

114 , testCatMaybe getTestDatabase

115 , testCatMaybe getTestDatabase

115 , testMaybeTable getTestDatabase

116 , testMaybeTable getTestDatabase

117+ , testAggregateMaybeTable getTestDatabase

116 , testNestedTables getTestDatabase

118 , testNestedTables getTestDatabase

117 , testMaybeTableApplicative getTestDatabase

119 , testMaybeTableApplicative getTestDatabase

118 , testLogicalFixities getTestDatabase

120 , testLogicalFixities getTestDatabase

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

555 _ -> sort selected === sort rows

557 _ -> sort selected === sort rows

556

558

557

559

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+

558data TwoTestTables f =

582data TwoTestTables f =

559 TwoTestTables

583 TwoTestTables

560 { testTable1 :: TestTable f

584 { testTable1 :: TestTable f