@@ -0,0 +1,637 @@
1+{-# language FlexibleContexts #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
6+{-# language TupleSections #-}
7+{-# language UndecidableInstances #-}
9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing
10+-- queries that complements the main "Rel8" API ('Query').
16+ -- * Interfacing with 'Query's
23+ -- * Aggregation and Ordering
28+ -- ** Magic 'Tabulation's
53+import Control.Applicative ( (<|>), empty, liftA2 )
54+import Control.Monad ( liftM2 )
55+import Data.Bifunctor ( Bifunctor, bimap, first, second )
56+import Data.Foldable ( traverse_ )
57+import Data.Function ( on )
58+import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
59+import Data.Int ( Int64 )
60+import Data.Kind ( Type )
61+import Data.Maybe ( fromMaybe )
62+import Prelude hiding ( lookup, zip, zipWith )
65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
68+import Control.Comonad ( extract )
71+import qualified Opaleye.Aggregate as Opaleye
72+import qualified Opaleye.Internal.Order as Opaleye
73+import qualified Opaleye.Internal.QueryArr as Opaleye
74+import qualified Opaleye.Order as Opaleye ( orderBy )
77+import Data.Profunctor ( dimap, lmap )
79+-- product-profunctors
80+import Data.Profunctor.Product
81+ ( ProductProfunctor, (***!)
82+ , SumProfunctor, (+++!)
84+import qualified Data.Profunctor.Product as PP
87+import Rel8.Aggregate ( Aggregates )
88+import Rel8.Expr ( Expr )
89+import Rel8.Expr.Aggregate ( countStar )
90+import Rel8.Expr.Bool ( true )
91+import Rel8.Order ( Order( Order ) )
92+import Rel8.Query ( Query )
93+import qualified Rel8.Query.Exists as Q ( exists, present, absent )
94+import Rel8.Query.Filter ( where_ )
95+import Rel8.Query.Limit ( limit )
96+import Rel8.Query.List ( catNonEmptyTable )
97+import qualified Rel8.Query.Maybe as Q ( optional )
98+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
99+import Rel8.Query.These ( alignBy )
100+import Rel8.Table ( Table, fromColumns, toColumns )
101+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
102+import Rel8.Table.Alternative
104+ , AlternativeTable, emptyTable
106+import Rel8.Table.Cols ( fromCols, toCols )
107+import Rel8.Table.Eq ( EqTable, (==:), eqTable )
108+import Rel8.Table.List ( ListTable( ListTable ) )
109+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
110+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
111+import Rel8.Table.Opaleye ( aggregator, unpackspec )
112+import Rel8.Table.Ord ( OrdTable )
113+import Rel8.Table.Order ( ascTable )
114+import Rel8.Table.Projection
115+ ( Biprojectable, biproject
116+ , Projectable, project
119+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
122+import Data.Functor.Apply ( Apply, liftF2 )
123+import Data.Functor.Bind ( Bind, (>>-) )
126+type Key :: Type -> Type
130+cat :: Table Expr k => Key k -> Query k
131+cat = maybe emptyTable pure
134+key :: (ProductProfunctor p, SumProfunctor p)
135+ => p a b -> p (Key a) (Key b)
136+key a = dimap from to (PP.empty +++! a)
138+ from = maybe (Left ()) Right
139+ to = either (const Nothing) Just
142+keyed :: (ProductProfunctor p, SumProfunctor p)
143+ => p k l -> p a b -> p (Key k, a) (Key l, b)
144+keyed k a = key k ***! a
147+type Predicate :: Type -> Type
148+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
151+instance Contravariant Predicate where
152+ contramap f (Predicate a) = Predicate (lmap f <$> a)
155+instance Semigroup (Predicate k) where
156+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb
159+instance Monoid (Predicate k) where
160+ mempty = Predicate Nothing
163+match :: EqTable k => Key k -> Predicate k
164+match = Predicate . fmap (==:)
167+ensure :: Predicate k -> Key k -> Query ()
168+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
171+-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also
172+-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed
173+-- monadically just like 'Query's, but the resulting join is more like a
174+-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the
175+-- @CROSS JOIN@ given by 'Query'.
177+-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in
178+-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing
179+-- stopping a 'Tabulation' from containing multiple rows with the same key, so
180+-- technically @Map k (NonEmpty a)@ is more accurate.
182+-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'littQuery'
183+-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the
184+-- caveats that come with the latter).
185+type Tabulation :: Type -> Type -> Type
186+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
189+instance Biprojectable Tabulation where
192+ (fromColumns . apply f . toColumns)
193+ (fromColumns . apply g . toColumns)
196+instance Bifunctor Tabulation where
197+ bimap f g (Tabulation a) = Tabulation $ \p ->
198+ bimap (fmap f) g <$> a (f >$< p)
201+instance Functor (Tabulation k) where
205+instance Projectable (Tabulation k) where
206+ project f = fmap (fromColumns . apply f . toColumns)
209+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is
210+-- @intersectionWith (liftA2 (<*>))@
211+instance EqTable k => Apply (Tabulation k) where
215+-- | @pure = 'liftQuery' . pure@
216+instance EqTable k => Applicative (Tabulation k) where
217+ pure = liftQuery . pure
221+instance EqTable k => Bind (Tabulation k) where
222+ Tabulation as >>- f = Tabulation $ \p -> do
227+ (k', b) <- bs (p' <> p)
232+instance EqTable k => Monad (Tabulation k) where
236+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
238+instance EqTable k => AltTable (Tabulation k) where
239+ as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs
242+instance EqTable k => AlternativeTable (Tabulation k) where
243+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
246+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is
247+-- @unionWith (liftA2 (<>))@.
248+instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
250+ (<>) = alignWith (theseTable id id (<>))
253+instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
258+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.
259+fromQuery :: Query (k, a) -> Tabulation k a
260+fromQuery = Tabulation . const . fmap (first pure)
263+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.
265+-- Note that the result of a 'toQuery' is undefined (will always return zero
266+-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while
267+-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.
269+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
270+-- an explicit set of keys:
275+-- a <- lookup k tabulation
279+-- Having said that, in practice, most legitimate uses of 'Tabulation' will
280+-- have a well-defined 'toQuery'. It would be possible in theory to encode
281+-- the necessary invariants at the type level using an indexed monad, but we
282+-- would lose the ability to use @do@-notation, which is the main benefit
283+-- of having 'Tabulation' as a monad in the first place.
285+-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@
286+-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any
287+-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where
288+-- @'toQuery' t'@ is well-defined. There are other valid permutations too.
289+-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in
290+-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.
291+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
292+toQuery (Tabulation f) = do
298+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@
299+-- values exist at every possible key @k@.
300+liftQuery :: Query a -> Tabulation k a
301+liftQuery = Tabulation . const . fmap (empty,)
304+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
305+-- Useful for 'Rel8.filter'ing a 'Tabulation'.
308+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById
310+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b
311+through f (Tabulation as) = Tabulation $ \p -> do
318+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.
319+lookup :: EqTable k => k -> Tabulation k a -> Query a
320+lookup k (Tabulation f) = do
328+-- | 'aggregate' aggregates the values within each key of a
329+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.
330+aggregate :: forall k aggregates exprs.
332+ , Aggregates aggregates exprs
334+ => Tabulation k aggregates -> Tabulation k exprs
335+aggregate (Tabulation f) = Tabulation $
336+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .
337+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .
340+ haggregator = dimap fromColumns fromCols aggregator
343+-- | 'distinct' ensures a 'Tabulation' has at most one value for
344+-- each key, i.e., it drops duplicates. In general it keeps only the
345+-- \"first\" value it encounters for each key, but note that \"first\" is
346+-- undefined unless you first call 'order'.
347+distinct :: EqTable k => Tabulation k a -> Tabulation k a
348+distinct (Tabulation f) = Tabulation $ \p ->
349+ -- workaround for https://github.com/tomjaguarpaw/haskell-opaleye/pull/518
350+ case fst (unsafePeekQuery (f p)) of
351+ Nothing -> limit 1 (f p)
355+ Opaleye.productQueryArr
356+ ( Opaleye.distinctOn (key unpackspec) fst
357+ . Opaleye.runSimpleQueryArr q
363+-- | 'order' orders the /values/ of a 'Tabulation' within their
364+-- respective keys. This specifies a defined order for 'distinct'.
365+-- It also defines the order of the lists produced by 'many' and
367+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
368+order ordering (Tabulation f) =
369+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f
371+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))
376+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's
377+-- use 'count' as an example to demonstrate this concept. Consider
381+-- count $ fromQuery $ values
382+-- [ (lit 'a', lit True)
383+-- , (lit 'a', lit False)
384+-- , (lit 'b', lit True)
388+-- You might expect this to be equivalent to the following 'Tabulation':
391+-- fromQuery $ values
397+-- However, it isn't quite. While the resulting 'Tabulation' does effectively
398+-- contain the above entries, it also behaves as though it contained the value
399+-- @0@ at every other possible key.
401+-- This means you can do:
406+-- orderCount <- count ordersByUserId
409+-- To see how many orders a user has (getting @0@ if they have no orders).
412+-- | 'count' returns a count of how many entries are in the given
413+-- 'Tabulation' at each key.
415+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at
416+-- every possible key that wasn't in the given 'Tabulation'.
417+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)
419+ fmap (maybeTable 0 id) .
422+ fmap (const countStar)
425+-- | 'optional' produces a \"magic\" 'Tabulation' whereby each
426+-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every
427+-- other possible key contains a single 'Rel8.nothingTable'.
429+-- This is used to implement 'leftAlignWith'.
430+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)
431+optional (Tabulation f) = Tabulation $ \p -> case p of
432+ Predicate Nothing -> fmap pure <$> f p
433+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do
439+-- | 'many' aggregates each entry with a particular key into a
440+-- single entry with all of the values contained in a 'ListTable'.
442+-- 'order' can be used to give this 'ListTable' a defined order.
444+-- The resulting 'Tabulation' is \"magic\" in that the value
445+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given
447+many :: (EqTable k, Table Expr a)
448+ => Tabulation k a -> Tabulation k (ListTable Expr a)
450+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
453+ fmap (listAgg . toCols)
456+-- | 'some' aggregates each entry with a particular key into a
457+-- single entry with all of the values contained in a 'NonEmptyTable'.
459+-- 'order' can be used to give this 'NonEmptyTable' a defined order.
460+some :: (EqTable k, Table Expr a)
461+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)
463+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
465+ fmap (nonEmptyAgg . toCols)
468+-- | 'exists' produces a \"magic\" 'Tabulation' which contains the
469+-- value 'Rel8.true' at each key in the given 'Tabulation', and the value
470+-- 'Rel8.false' at every other possible key.
471+exists :: Tabulation k a -> Tabulation k (Expr Bool)
472+exists (Tabulation f) = Tabulation $ \p -> case p of
473+ Predicate Nothing -> (true <$) <$> f p
474+ _ -> fmap (empty,) $ Q.exists $ do
479+-- | 'present' produces a 'Tabulation' where a single @()@ row
480+-- exists for every key that was present in the given 'Tabulation'.
482+-- This is used to implement 'similarity'.
483+present :: Tabulation k a -> Tabulation k ()
484+present (Tabulation f) = Tabulation $ \p -> do
491+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists
492+-- at every possible key that absent from the given 'Tabulation'.
494+-- This is used to implement 'difference'.
495+absent :: Tabulation k a -> Tabulation k ()
496+absent (Tabulation f) = Tabulation $ \p -> do
503+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
505+-- Analogous to 'Data.Semialign.align'.
507+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
511+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
513+-- Analogous to 'Data.Semialign.alignWith'.
514+alignWith :: EqTable k
515+ => (TheseTable Expr a b -> c)
516+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
517+alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
518+ tkab <- liftF2 (alignBy condition) as bs p
520+ k = recover $ bimap fst fst tkab
521+ tab = bimap snd snd tkab
524+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')
525+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =
527+ Nothing -> extract mb
528+ Just a -> case extract mb of
529+ Nothing -> extract ma
530+ Just b -> case a <$ mma <|>: b <$ mmb of
531+ MaybeTable _ c -> pure (extract c)
534+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
536+-- Analogous to 'Data.Semialign.rpadZip'.
538+-- Note that you can achieve the same effect with 'optional' and the
539+-- 'Applicative' instance for 'Tabulation', i.e., this is just
540+-- @\left right -> liftA2 (,) left (optional right). You can also
541+-- use @do@-notation.
542+leftAlign :: EqTable k
543+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
544+leftAlign = leftAlignWith (,)
547+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
549+-- Analogous to 'Data.Semialign.rpadZipWith'.
551+-- Note that you can achieve the same effect with 'optional' and the
552+-- 'Applicative' instance for 'Tabulation', i.e., this is just
553+-- @\f left right -> liftA2 f left (optional right). You can also
554+-- use @do@-notation.
555+leftAlignWith :: EqTable k
556+ => (a -> MaybeTable Expr b -> c)
557+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
558+leftAlignWith f left right = liftA2 f left (optional right)
561+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
563+-- Analogous to 'Data.Semialign.lpadZip'.
565+-- Note that you can achieve the same effect with 'optional' and the
566+-- 'Applicative' instance for 'Tabulation', i.e., this is just
567+-- @\left right -> liftA2 (flip (,)) right (optional left). You can
568+-- also use @do@-notation.
569+rightAlign :: EqTable k
570+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)
571+rightAlign = rightAlignWith (,)
574+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
576+-- Analogous to 'Data.Semialign.lpadZipWith'.
578+-- Note that you can achieve the same effect with 'optional' and the
579+-- 'Applicative' instance for 'Tabulation', i.e., this is just
580+-- @\f left right -> liftA2 (flip f) right (optional left). You can
581+-- also use @do@-notation.
582+rightAlignWith :: EqTable k
583+ => (MaybeTable Expr a -> b -> c)
584+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
585+rightAlignWith f left right = liftA2 (flip f) right (optional left)
588+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
590+-- Analagous to 'Data.Semialign.zip'.
592+-- Note that you can achieve the same effect with the 'Applicative' instance
593+-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use
596+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
600+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
602+-- Analagous to 'Data.Semialign.zipWith'.
604+-- Note that you can achieve the same effect with the 'Applicative' instance
605+-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use
608+ => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
612+-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)
613+-- based on the common key columns.
615+-- The result is a subset of the left tabulation where only entries which have
616+-- a corresponding entry in the right tabulation are kept.
618+-- Note that you can achieve a similar effect with 'present' and the
619+-- 'Applicative' instance of 'Tabulation', i.e., this is just
620+-- @\left right -> left <* present right@. You can also use
622+similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
623+similarity a b = a <* present b
626+-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)
627+-- based on the common key columns.
629+-- The result is a subset of the left tabulation where only entries which do
630+-- not have a corresponding entry in the right tabulation are kept.
632+-- Note that you can achieve a similar effect with 'absent' and the
633+-- 'Applicative' instance of 'Tabulation', i.e., this is just
634+-- @\left right -> left <* absent right@. You can also use
636+difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
637+difference a b = a <* absent b