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
53import Control.Applicative ( (<|>), empty, liftA2 )
54import Control.Monad ( liftM2 )
55import Data.Bifunctor ( Bifunctor, bimap, first, second )
56import Data.Foldable ( traverse_ )
57import Data.Function ( on )
58import Data.Functor.Contravariant ( Contravariant, (>$<), contramap )
59import Data.Int ( Int64 )
60import Data.Kind ( Type )
61import Data.Maybe ( fromMaybe )
62import Prelude hiding ( lookup, zip, zipWith )
65import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
68import Control.Comonad ( extract )
71import qualified Opaleye.Aggregate as Opaleye
72import qualified Opaleye.Internal.Order as Opaleye
73import qualified Opaleye.Internal.QueryArr as Opaleye
74import qualified Opaleye.Order as Opaleye ( orderBy )
77import Data.Profunctor ( dimap, lmap )
80import Data.Profunctor.Product
81 ( ProductProfunctor, (***!)
82 , SumProfunctor, (+++!)
84import qualified Data.Profunctor.Product as PP
87import Rel8.Aggregate ( Aggregates )
88import Rel8.Expr ( Expr )
89import Rel8.Expr.Aggregate ( countStar )
90import Rel8.Expr.Bool ( true )
91import Rel8.Order ( Order( Order ) )
92import Rel8.Query ( Query )
93import qualified Rel8.Query.Exists as Q ( exists, present, absent )
94import Rel8.Query.Filter ( where_ )
95import Rel8.Query.Limit ( limit )
96import Rel8.Query.List ( catNonEmptyTable )
97import qualified Rel8.Query.Maybe as Q ( optional )
98import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
99import Rel8.Query.These ( alignBy )
100import Rel8.Table ( Table, fromColumns, toColumns )
101import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
102import Rel8.Table.Alternative
104 , AlternativeTable, emptyTable
106import Rel8.Table.Cols ( fromCols, toCols )
107import Rel8.Table.Eq ( EqTable, (==:), eqTable )
108import Rel8.Table.List ( ListTable( ListTable ) )
109import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
110import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
111import Rel8.Table.Opaleye ( aggregator, unpackspec )
112import Rel8.Table.Ord ( OrdTable )
113import Rel8.Table.Order ( ascTable )
114import Rel8.Table.Projection
115 ( Biprojectable, biproject
116 , Projectable, project
119import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
122import Data.Functor.Apply ( Apply, liftF2 )
123import Data.Functor.Bind ( Bind, (>>-) )
126type Key :: Type -> Type
130cat :: Table Expr k => Key k -> Query k
131cat = maybe emptyTable pure
134key :: (ProductProfunctor p, SumProfunctor p)
135 => p a b -> p (Key a) (Key b)
136key a = dimap from to (PP.empty +++! a)
138 from = maybe (Left ()) Right
139 to = either (const Nothing) Just
142keyed :: (ProductProfunctor p, SumProfunctor p)
143 => p k l -> p a b -> p (Key k, a) (Key l, b)
144keyed k a = key k ***! a
147type Predicate :: Type -> Type
148newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
151instance Contravariant Predicate where
152 contramap f (Predicate a) = Predicate (lmap f <$> a)
155instance Semigroup (Predicate k) where
156 Predicate ma <> Predicate mb = Predicate $ ma <|> mb
159instance Monoid (Predicate k) where
160 mempty = Predicate Nothing
163match :: EqTable k => Key k -> Predicate k
164match = Predicate . fmap (==:)
167ensure :: Predicate k -> Key k -> Query ()
168ensure (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 'liftQuery'
183-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the
184-- caveats that come with the latter).
185type Tabulation :: Type -> Type -> Type
186newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
189instance Biprojectable Tabulation where
192 (fromColumns . apply f . toColumns)
193 (fromColumns . apply g . toColumns)
196instance Bifunctor Tabulation where
197 bimap f g (Tabulation a) = Tabulation $ \p ->
198 bimap (fmap f) g <$> a (f >$< p)
201instance Functor (Tabulation k) where
205instance 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 (<*>))@
211instance EqTable k => Apply (Tabulation k) where
215-- | @pure = 'liftQuery' . pure@
216instance EqTable k => Applicative (Tabulation k) where
217 pure = liftQuery . pure
221instance EqTable k => Bind (Tabulation k) where
222 Tabulation as >>- f = Tabulation $ \p -> do
227 (k', b) <- bs (p' <> p)
232instance EqTable k => Monad (Tabulation k) where
236-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
238instance EqTable k => AltTable (Tabulation k) where
239 as <|>: bs = catNonEmptyTable `through` ((<>) `on` some) as bs
242instance 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 (<>))@.
248instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
250 (<>) = alignWith (theseTable id id (<>))
253instance (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@.
259fromQuery :: Query (k, a) -> Tabulation k a
260fromQuery = 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'.
291toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
292toQuery (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@.
300liftQuery :: Query a -> Tabulation k a
301liftQuery = 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
310through :: (a -> Query b) -> Tabulation k a -> Tabulation k b
311through f (Tabulation as) = Tabulation $ \p -> do
318-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.
319lookup :: EqTable k => k -> Tabulation k a -> Query a
320lookup 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.
330aggregate :: forall k aggregates exprs.
332 , Aggregates aggregates exprs
334 => Tabulation k aggregates -> Tabulation k exprs
335aggregate (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'.
347distinct :: EqTable k => Tabulation k a -> Tabulation k a
348distinct (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
367order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
368order 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':
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'.
417count :: 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'.
430optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)
431optional (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
447many :: (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.
460some :: (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.
471exists :: Tabulation k a -> Tabulation k (Expr Bool)
472exists (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'.
483present :: Tabulation k a -> Tabulation k ()
484present (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'.
495absent :: Tabulation k a -> Tabulation k ()
496absent (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'.
514alignWith :: EqTable k
515 => (TheseTable Expr a b -> c)
516 -> Tabulation k a -> Tabulation k b -> Tabulation k c
517alignWith 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
542leftAlign :: EqTable k
543 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
544leftAlign = 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
555leftAlignWith :: EqTable k
556 => (a -> MaybeTable Expr b -> c)
557 -> Tabulation k a -> Tabulation k b -> Tabulation k c
558leftAlignWith 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.
569rightAlign :: EqTable k
570 => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)
571rightAlign = 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.
582rightAlignWith :: EqTable k
583 => (MaybeTable Expr a -> b -> c)
584 -> Tabulation k a -> Tabulation k b -> Tabulation k c
585rightAlignWith 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
622similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
623similarity 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
636difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
637difference a b = a <* absent b
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list