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 ( fromJust, 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.Order as Opaleye ( orderBy, distinctOnExplicit )
75import Data.Profunctor ( dimap, lmap )
78import Data.Profunctor.Product
79 ( ProductProfunctor, (***!)
80 , SumProfunctor, (+++!)
82import qualified Data.Profunctor.Product as PP
85import Rel8.Aggregate ( Aggregates )
86import Rel8.Expr ( Expr )
87import Rel8.Expr.Aggregate ( countStar )
88import Rel8.Expr.Bool ( true )
89import Rel8.Order ( Order( Order ) )
90import Rel8.Query ( Query )
91import qualified Rel8.Query.Exists as Q ( exists, present, absent )
92import Rel8.Query.Filter ( where_ )
93import Rel8.Query.List ( catNonEmptyTable )
94import qualified Rel8.Query.Maybe as Q ( optional )
95import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96import Rel8.Query.Rebind ( rebind )
97import Rel8.Query.These ( alignBy )
98import Rel8.Table ( Table, fromColumns, toColumns )
99import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
100import Rel8.Table.Alternative
102 , AlternativeTable, emptyTable
104import Rel8.Table.Cols ( fromCols, toCols )
105import Rel8.Table.Eq ( EqTable, (==:), eqTable )
106import Rel8.Table.List ( ListTable( ListTable ) )
107import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
108import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
109import Rel8.Table.Opaleye ( aggregator, unpackspec )
110import Rel8.Table.Ord ( OrdTable )
111import Rel8.Table.Order ( ascTable )
112import Rel8.Table.Projection
113 ( Biprojectable, biproject
114 , Projectable, project
117import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
120import Data.Functor.Apply ( Apply, liftF2 )
121import Data.Functor.Bind ( Bind, (>>-) )
124type Key :: Type -> Type
128cat :: Table Expr k => Key k -> Query k
129cat = maybe emptyTable pure
132key :: (ProductProfunctor p, SumProfunctor p)
133 => p a b -> p (Key a) (Key b)
134key a = dimap from to (PP.empty +++! a)
136 from = maybe (Left ()) Right
137 to = either (const Nothing) Just
140keyed :: (ProductProfunctor p, SumProfunctor p)
141 => p k l -> p a b -> p (Key k, a) (Key l, b)
142keyed k a = key k ***! a
145type Predicate :: Type -> Type
146newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
149instance Contravariant Predicate where
150 contramap f (Predicate a) = Predicate (lmap f <$> a)
153instance Semigroup (Predicate k) where
154 Predicate ma <> Predicate mb = Predicate $ ma <|> mb
157instance Monoid (Predicate k) where
158 mempty = Predicate Nothing
161match :: EqTable k => Key k -> Predicate k
162match = Predicate . fmap (==:)
165ensure :: Predicate k -> Key k -> Query ()
166ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
169-- | A @'Tabulation' k a@ is like a @'Query' a@, except that each row also
170-- has a key @k@ in addition to the value @a@. 'Tabulation's can be composed
171-- monadically just like 'Query's, but the resulting join is more like a
172-- @NATURAL JOIN@ (based on the common key column(s) @k@) than the
173-- @CROSS JOIN@ given by 'Query'.
175-- Another way to think of @'Tabulation' k a@ is as analogous to @Map k a@ in
176-- the same way @'Query' a@ is analogous to @[a]@. However, there's nothing
177-- stopping a 'Tabulation' from containing multiple rows with the same key, so
178-- technically @Map k (NonEmpty a)@ is more accurate.
180-- 'Tabulation's can be created from 'Query's with 'fromQuery' and 'liftQuery'
181-- and converted back to 'Query's with 'lookup' and 'toQuery' (though note the
182-- caveats that come with the latter).
183type Tabulation :: Type -> Type -> Type
184newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
187instance Biprojectable Tabulation where
190 (fromColumns . apply f . toColumns)
191 (fromColumns . apply g . toColumns)
194instance Bifunctor Tabulation where
195 bimap f g (Tabulation a) = Tabulation $ \p ->
196 bimap (fmap f) g <$> a (f >$< p)
199instance Functor (Tabulation k) where
203instance Projectable (Tabulation k) where
204 project f = fmap (fromColumns . apply f . toColumns)
207-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is
208-- @intersectionWith (liftA2 (<*>))@
209instance EqTable k => Apply (Tabulation k) where
213-- | @pure = 'liftQuery' . pure@
214instance EqTable k => Applicative (Tabulation k) where
215 pure = liftQuery . pure
219instance EqTable k => Bind (Tabulation k) where
220 Tabulation as >>- f = Tabulation $ \p -> do
225 (k', b) <- bs (p' <> p)
230instance EqTable k => Monad (Tabulation k) where
234-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
236instance EqTable k => AltTable (Tabulation k) where
241 (Left as, Left bs) -> liftQuery $ as <|>: bs
242 (Right as, Right bs) -> fromQuery $ as <|>: bs
243 _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs
246instance EqTable k => AlternativeTable (Tabulation k) where
247 emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
250-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is
251-- @unionWith (liftA2 (<>))@.
252instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
254 (<>) = alignWith (theseTable id id (<>))
257instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
262-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.
263fromQuery :: Query (k, a) -> Tabulation k a
264fromQuery = Tabulation . const . fmap (first pure)
267-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.
269-- Note that the result of a 'toQuery' is undefined (will always return zero
270-- rows) on 'Tabulation's constructed with 'liftQuery' or 'pure'. So while
271-- @toQuery . fromQuery@ is always @id@, @fromQuery . toQuery@ is not.
273-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
274-- an explicit set of keys:
279-- a <- lookup k tabulation
283-- Having said that, in practice, most legitimate uses of 'Tabulation' will
284-- have a well-defined 'toQuery'. It would be possible in theory to encode
285-- the necessary invariants at the type level using an indexed monad, but we
286-- would lose the ability to use @do@-notation, which is the main benefit
287-- of having 'Tabulation' as a monad in the first place.
289-- In particular, @'toQuery' t@ is well-defined for any 'Tabulation' @t@
290-- defined as @t = fromQuery _@. @'toQuery' t@ is also well-defined for any
291-- 'Tabulation' @t@ defined as @t = t' >>= _@ or @t = t' *> _@ where
292-- @'toQuery' t'@ is well-defined. There are other valid permutations too.
293-- Generally, anything that uses 'fromQuery' at some point, unless wrapped in
294-- a top-level 'present' or 'absent', will have a well-defined 'toQuery'.
295toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
296toQuery (Tabulation f) = do
302-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@
303-- values exist at every possible key @k@.
304liftQuery :: Query a -> Tabulation k a
305liftQuery = Tabulation . const . fmap (empty,)
308-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
309-- Useful for 'Rel8.filter'ing a 'Tabulation'.
312-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById
314through :: (a -> Query b) -> Tabulation k a -> Tabulation k b
315through f (Tabulation as) = Tabulation $ \p -> do
322-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.
323lookup :: EqTable k => k -> Tabulation k a -> Query a
324lookup k (Tabulation f) = do
332-- | 'aggregate' aggregates the values within each key of a
333-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.
334aggregate :: forall k aggregates exprs.
336 , Aggregates aggregates exprs
338 => Tabulation k aggregates -> Tabulation k exprs
339aggregate (Tabulation f) = Tabulation $
340 mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .
341 fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .
344 haggregator = dimap fromColumns fromCols aggregator
347-- | 'distinct' ensures a 'Tabulation' has at most one value for
348-- each key, i.e., it drops duplicates. In general it keeps only the
349-- \"first\" value it encounters for each key, but note that \"first\" is
350-- undefined unless you first call 'order'.
351distinct :: EqTable k => Tabulation k a -> Tabulation k a
352distinct (Tabulation f) = Tabulation $
353 mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f
356-- | 'order' orders the /values/ of a 'Tabulation' within their
357-- respective keys. This specifies a defined order for 'distinct'.
358-- It also defines the order of the lists produced by 'many' and
360order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
361order ordering (Tabulation f) =
362 Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f
364 Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))
369-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's
370-- use 'count' as an example to demonstrate this concept. Consider
374-- count $ fromQuery $ values
375-- [ (lit 'a', lit True)
376-- , (lit 'a', lit False)
377-- , (lit 'b', lit True)
381-- You might expect this to be equivalent to the following 'Tabulation':
390-- However, it isn't quite. While the resulting 'Tabulation' does effectively
391-- contain the above entries, it also behaves as though it contained the value
392-- @0@ at every other possible key.
394-- This means you can do:
399-- orderCount <- count ordersByUserId
402-- To see how many orders a user has (getting @0@ if they have no orders).
405-- | 'count' returns a count of how many entries are in the given
406-- 'Tabulation' at each key.
408-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at
409-- every possible key that wasn't in the given 'Tabulation'.
410count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)
412 fmap (maybeTable 0 id) .
415 fmap (const countStar)
418-- | 'optional' produces a \"magic\" 'Tabulation' whereby each
419-- entry in the given 'Tabulation' is wrapped in 'Rel8.justTable', and every
420-- other possible key contains a single 'Rel8.nothingTable'.
422-- This is used to implement 'leftAlignWith'.
423optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)
424optional (Tabulation f) = Tabulation $ \p -> case p of
425 Predicate Nothing -> fmap pure <$> f p
426 _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do
432-- | 'many' aggregates each entry with a particular key into a
433-- single entry with all of the values contained in a 'ListTable'.
435-- 'order' can be used to give this 'ListTable' a defined order.
437-- The resulting 'Tabulation' is \"magic\" in that the value
438-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given
440many :: (EqTable k, Table Expr a)
441 => Tabulation k a -> Tabulation k (ListTable Expr a)
443 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
446 fmap (listAgg . toCols)
449-- | 'some' aggregates each entry with a particular key into a
450-- single entry with all of the values contained in a 'NonEmptyTable'.
452-- 'order' can be used to give this 'NonEmptyTable' a defined order.
453some :: (EqTable k, Table Expr a)
454 => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)
456 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
458 fmap (nonEmptyAgg . toCols)
461-- | 'exists' produces a \"magic\" 'Tabulation' which contains the
462-- value 'Rel8.true' at each key in the given 'Tabulation', and the value
463-- 'Rel8.false' at every other possible key.
464exists :: Tabulation k a -> Tabulation k (Expr Bool)
465exists (Tabulation f) = Tabulation $ \p -> case p of
466 Predicate Nothing -> (true <$) <$> f p
467 _ -> fmap (empty,) $ Q.exists $ do
472-- | 'present' produces a 'Tabulation' where a single @()@ row
473-- exists for every key that was present in the given 'Tabulation'.
475-- This is used to implement 'similarity'.
476present :: Tabulation k a -> Tabulation k ()
477present (Tabulation f) = Tabulation $ \p -> do
484-- | 'absent' produces a 'Tabulation' where a single @()@ row exists
485-- at every possible key that absent from the given 'Tabulation'.
487-- This is used to implement 'difference'.
488absent :: Tabulation k a -> Tabulation k ()
489absent (Tabulation f) = Tabulation $ \p -> do
496-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
498-- Analogous to 'Data.Semialign.align'.
500 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
504-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
506-- Analogous to 'Data.Semialign.alignWith'.
507alignWith :: EqTable k
508 => (TheseTable Expr a b -> c)
509 -> Tabulation k a -> Tabulation k b -> Tabulation k c
510alignWith f (Tabulation as) (Tabulation bs) = Tabulation $ \p -> do
511 tkab <- liftF2 (alignBy condition) as bs p
512 k <- traverse (rebind "key") $ recover $ bimap fst fst tkab
514 tab = bimap snd snd tkab
517 condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')
518 recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =
520 Nothing -> extract mb
521 Just a -> case extract mb of
522 Nothing -> extract ma
523 Just b -> case a <$ mma <|>: b <$ mmb of
524 MaybeTable _ c -> pure (extract c)
527-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
529-- Analogous to 'Data.Semialign.rpadZip'.
531-- Note that you can achieve the same effect with 'optional' and the
532-- 'Applicative' instance for 'Tabulation', i.e., this is just
533-- @\left right -> liftA2 (,) left (optional right). You can also
535leftAlign :: EqTable k
536 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
537leftAlign = leftAlignWith (,)
540-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
542-- Analogous to 'Data.Semialign.rpadZipWith'.
544-- Note that you can achieve the same effect with 'optional' and the
545-- 'Applicative' instance for 'Tabulation', i.e., this is just
546-- @\f left right -> liftA2 f left (optional right). You can also
548leftAlignWith :: EqTable k
549 => (a -> MaybeTable Expr b -> c)
550 -> Tabulation k a -> Tabulation k b -> Tabulation k c
551leftAlignWith f left right = liftA2 f left (optional right)
554-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
556-- Analogous to 'Data.Semialign.lpadZip'.
558-- Note that you can achieve the same effect with 'optional' and the
559-- 'Applicative' instance for 'Tabulation', i.e., this is just
560-- @\left right -> liftA2 (flip (,)) right (optional left). You can
561-- also use @do@-notation.
562rightAlign :: EqTable k
563 => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)
564rightAlign = rightAlignWith (,)
567-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
569-- Analogous to 'Data.Semialign.lpadZipWith'.
571-- Note that you can achieve the same effect with 'optional' and the
572-- 'Applicative' instance for 'Tabulation', i.e., this is just
573-- @\f left right -> liftA2 (flip f) right (optional left). You can
574-- also use @do@-notation.
575rightAlignWith :: EqTable k
576 => (MaybeTable Expr a -> b -> c)
577 -> Tabulation k a -> Tabulation k b -> Tabulation k c
578rightAlignWith f left right = liftA2 (flip f) right (optional left)
581-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
583-- Analagous to 'Data.Semialign.zip'.
585-- Note that you can achieve the same effect with the 'Applicative' instance
586-- of 'Tabulation', i.e., this is just @'liftA2 (,)'@. You can also use
589 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
593-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
595-- Analagous to 'Data.Semialign.zipWith'.
597-- Note that you can achieve the same effect with the 'Applicative' instance
598-- of 'Tabulation', i.e., this is just @'liftA2'@. You can also use
601 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
605-- | Performs a [@NATURAL SEMI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Semijoin_%28%E2%8B%89%29%28%E2%8B%8A%29)
606-- based on the common key columns.
608-- The result is a subset of the left tabulation where only entries which have
609-- a corresponding entry in the right tabulation are kept.
611-- Note that you can achieve a similar effect with 'present' and the
612-- 'Applicative' instance of 'Tabulation', i.e., this is just
613-- @\left right -> left <* present right@. You can also use
615similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
616similarity a b = a <* present b
619-- | Performs a [@NATURAL ANTI JOIN@](https://en.wikipedia.org/wiki/Relational_algebra#Antijoin_%28%E2%96%B7%29)
620-- based on the common key columns.
622-- The result is a subset of the left tabulation where only entries which do
623-- not have a corresponding entry in the right tabulation are kept.
625-- Note that you can achieve a similar effect with 'absent' and the
626-- 'Applicative' instance of 'Tabulation', i.e., this is just
627-- @\left right -> left <* absent right@. You can also use
629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
630difference a b = a <* absent b
633-- | 'Tabulation's can be produced with either 'fromQuery' or 'liftQuery', and
634-- in some cases we might want to treat these differently. 'peek' uses
635-- 'unsafePeekQuery' to determine which type of 'Tabulation' we have.
636peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))
637peek (Tabulation f) = Tabulation $ \p ->
638 pure $ (empty,) $ case unsafePeekQuery (f p) of
639 (Nothing, _) -> Left $ fmap snd (f p)
640 (Just _, _) -> Right $ fmap (first fromJust) (f p)
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