@@ -1,131 +1,254 @@
1−{-# language DeriveFunctor #-}
2−{-# language DerivingStrategies #-}
31{-# language FlexibleContexts #-}
4−{-# language LambdaCase #-}
2+{-# language MonoLocalBinds #-}
3+{-# language ScopedTypeVariables #-}
4+{-# language StandaloneKindSignatures #-}
5+{-# language TypeApplications #-}
56{-# language TupleSections #-}
67{-# language UndecidableInstances #-}
78
9+-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing
10+-- queries that complements the main "Rel8" API ('Query').
11+
812module Rel8.Tabulate
9− ( Tabulation
10− , runTabulation
11− , tabulate
12− , tabulateA
13+ (
14+ Tabulation
15+
16+ -- * Interfacing with 'Query's
1317 , fromQuery
18+ , toQuery
1419 , liftQuery
15− , prebind
16− , postbind
17− , indexed
18− , ifilter
20+ , through
1921 , lookup
22+
23+ -- * Aggregation and Ordering
24+ , aggregate
25+ , distinct
26+ , order
27+
28+ -- ** Magic 'Tabulation's
29+ -- $magic
30+ , count
31+ , optional
32+ , many
33+ , some
34+ , exists
35+ , present
36+ , absent
37+
38+ -- * Natural joins
2039 , align
2140 , alignWith
2241 , leftAlign
2342 , leftAlignWith
43+ , rightAlign
44+ , rightAlignWith
2445 , zip
2546 , zipWith
2647 , similarity
2748 , difference
28− , aggregateTabulation
29− , orderTabulation
30− , singularize
31− , optionalTabulation
32− , manyTabulation
33− , someTabulation
3449 )
3550where
3651
3752-- base
38−import Control.Applicative ( liftA2 )
39−import Control.Monad ( join, liftM2 )
40−import Data.Bifunctor ( bimap, first )
53+import Control.Applicative ( (<|>), empty, liftA2 )
54+import Control.Monad ( liftM2 )
55+import Data.Bifunctor ( Bifunctor, bimap, first, second )
4156import Data.Foldable ( traverse_ )
42−import Data.Functor.Contravariant ( (>$<) )
43−import Data.Maybe ( fromMaybe )
44−import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
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 ( fromJust, fromMaybe )
62+import Prelude hiding ( lookup, zip, zipWith )
63+
64+-- bifunctors
65+import Data.Bifunctor.Clown ( Clown( Clown ), runClown )
66+
67+-- comonad
68+import Control.Comonad ( extract )
69+
70+-- opaleye
71+import qualified Opaleye.Aggregate as Opaleye
72+import qualified Opaleye.Order as Opaleye ( orderBy, distinctOnExplicit )
73+
74+-- profunctors
75+import Data.Profunctor ( dimap, lmap )
76+
77+-- product-profunctors
78+import Data.Profunctor.Product
79+ ( ProductProfunctor, (***!)
80+ , SumProfunctor, (+++!)
81+ )
82+import qualified Data.Profunctor.Product as PP
4583
4684-- rel8
47−import Rel8.Aggregate ( Aggregate )
85+import Rel8.Aggregate ( Aggregates )
4886import Rel8.Expr ( Expr )
49−import Rel8.Expr.Bool ( not_, true )
50−import Rel8.Order ( Order )
87+import Rel8.Expr.Aggregate ( countStar )
88+import Rel8.Expr.Bool ( true )
89+import Rel8.Order ( Order( Order ) )
5190import Rel8.Query ( Query )
52−import Rel8.Query.Aggregate ( aggregate )
53−import Rel8.Query.Exists ( withBy, withoutBy )
54−import Rel8.Query.Filter ( filter, where_ )
55−import Rel8.Query.Maybe ( optional )
56−import Rel8.Query.Order ( orderBy )
91+import qualified Rel8.Query.Exists as Q ( exists, present, absent )
92+import Rel8.Query.Filter ( where_ )
93+import Rel8.Query.List ( catNonEmptyTable )
94+import qualified Rel8.Query.Maybe as Q ( optional )
95+import Rel8.Query.Opaleye ( mapOpaleye, unsafePeekQuery )
96+import Rel8.Query.Rebind ( rebind )
5797import Rel8.Query.These ( alignBy )
58−import Rel8.Table ( Table )
59−import Rel8.Table.Aggregate ( groupBy, headAgg, listAgg, nonEmptyAgg )
98+import Rel8.Table ( Table, fromColumns, toColumns )
99+import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
60100import Rel8.Table.Alternative
61101 ( AltTable, (<|>:)
62102 , AlternativeTable, emptyTable
63103 )
64−import Rel8.Table.Eq ( EqTable, (==:) )
65−import Rel8.Table.List ( ListTable )
66−import Rel8.Table.Maybe ( MaybeTable, maybeTable )
67−import Rel8.Table.NonEmpty ( NonEmptyTable )
68−import Rel8.Table.These ( TheseTable, theseTable )
69−import Rel8.Table.Undefined ( undefined )
104+import Rel8.Table.Cols ( fromCols, toCols )
105+import Rel8.Table.Eq ( EqTable, (==:), eqTable )
106+import Rel8.Table.List ( ListTable( ListTable ) )
107+import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), maybeTable )
108+import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
109+import Rel8.Table.Opaleye ( aggregator, unpackspec )
110+import Rel8.Table.Ord ( OrdTable )
111+import Rel8.Table.Order ( ascTable )
112+import Rel8.Table.Projection
113+ ( Biprojectable, biproject
114+ , Projectable, project
115+ , apply
116+ )
117+import Rel8.Table.These ( TheseTable( TheseTable ), theseTable )
70118
71119-- semigroupoids
72120import Data.Functor.Apply ( Apply, liftF2 )
73−import Data.Functor.Bind ( Bind )
74−import qualified Data.Functor.Bind
75−import Data.Semigroup.Traversable.Class ( bitraverse1 )
121+import Data.Functor.Bind ( Bind, (>>-) )
122+
123+
124+type Key :: Type -> Type
125+type Key = Maybe
126+
127+
128+cat :: Table Expr k => Key k -> Query k
129+cat = maybe emptyTable pure
130+
131+
132+key :: (ProductProfunctor p, SumProfunctor p)
133+ => p a b -> p (Key a) (Key b)
134+key a = dimap from to (PP.empty +++! a)
135+ where
136+ from = maybe (Left ()) Right
137+ to = either (const Nothing) Just
138+
139+
140+keyed :: (ProductProfunctor p, SumProfunctor p)
141+ => p k l -> p a b -> p (Key k, a) (Key l, b)
142+keyed k a = key k ***! a
76143
77144
78−-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
79−-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
80−-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
145+type Predicate :: Type -> Type
146+newtype Predicate a = Predicate (Maybe (a -> Expr Bool))
147+
148+
149+instance Contravariant Predicate where
150+ contramap f (Predicate a) = Predicate (lmap f <$> a)
151+
152+
153+instance Semigroup (Predicate k) where
154+ Predicate ma <> Predicate mb = Predicate $ ma <|> mb
155+
156+
157+instance Monoid (Predicate k) where
158+ mempty = Predicate Nothing
159+
160+
161+match :: EqTable k => Key k -> Predicate k
162+match = Predicate . fmap (==:)
163+
164+
165+ensure :: Predicate k -> Key k -> Query ()
166+ensure (Predicate mp) = traverse_ (\k -> traverse_ (\p -> where_ (p k)) mp)
167+
168+
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'.
174+--
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.
81179--
82−-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
83−-- be composed with 'Query's with 'prebind' or 'postbind' to form new
84−-- 'Tabulation's.
85−newtype Tabulation k a = Tabulation (Either k k -> Query (Maybe k, a))
86− deriving stock Functor
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).
183+type Tabulation :: Type -> Type -> Type
184+newtype Tabulation k a = Tabulation (Predicate k -> Query (Key k, a))
87185
88186
187+instance Biprojectable Tabulation where
188+ biproject f g =
189+ bimap
190+ (fromColumns . apply f . toColumns)
191+ (fromColumns . apply g . toColumns)
192+
193+
194+instance Bifunctor Tabulation where
195+ bimap f g (Tabulation a) = Tabulation $ \p ->
196+ bimap (fmap f) g <$> a (f >$< p)
197+
198+
199+instance Functor (Tabulation k) where
200+ fmap = second
201+
202+
203+instance Projectable (Tabulation k) where
204+ project f = fmap (fromColumns . apply f . toColumns)
205+
206+
207+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<.>)@ is
208+-- @intersectionWith (liftA2 (<*>))@
89209instance EqTable k => Apply (Tabulation k) where
90210 liftF2 = liftA2
91211
92212
213+-- | @pure = 'liftQuery' . pure@
93214instance EqTable k => Applicative (Tabulation k) where
94215 pure = liftQuery . pure
95216 liftA2 = liftM2
96217
97218
98219instance EqTable k => Bind (Tabulation k) where
99− join = join
220+ Tabulation as >>- f = Tabulation $ \p -> do
221+ (k, a) <- as p
222+ case f a of
223+ Tabulation bs -> do
224+ let p' = match k
225+ (k', b) <- bs (p' <> p)
226+ ensure p' k'
227+ pure (k' <|> k, b)
100228
101229
102230instance EqTable k => Monad (Tabulation k) where
103− Tabulation as >>= f = Tabulation $ \i -> do
104− (mk, a) <- as i
105− case mk of
106− Nothing -> case f a of
107− Tabulation bs -> bs i
108− Just k -> case f a of
109− Tabulation bs -> do
110− (mk', b) <- bs (Right k)
111− case mk' of
112− Nothing -> pure (mk, b)
113− Just k' -> do
114− where_ $ k ==: k'
115− pure (mk', b)
231+ (>>=) = (>>-)
116232
117233
234+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
235+-- @unionWith (<>)@.
118236instance EqTable k => AltTable (Tabulation k) where
119− kas <|>: kbs = do
120− as <- toQuery kas
121− bs <- toQuery kbs
122− fromQuery $ as <|>: bs
237+ tas <|>: tbs = do
238+ eas <- peek tas
239+ ebs <- peek tbs
240+ case (eas, ebs) of
241+ (Left as, Left bs) -> liftQuery $ as <|>: bs
242+ (Right as, Right bs) -> fromQuery $ as <|>: bs
243+ _ -> catNonEmptyTable `through` ((<>) `on` some) tas tbs
123244
124245
125246instance EqTable k => AlternativeTable (Tabulation k) where
126− emptyTable = fromQuery emptyTable
247+ emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
127248
128249
250+-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is
251+-- @unionWith (liftA2 (<>))@.
129252instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
130253 where
131254 (<>) = alignWith (theseTable id id (<>))
@@ -136,271 +259,382 @@ instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
136259 mempty = emptyTable
137260
138261
139−-- | This "undoes" 'fromQuery'.
140−--
141−-- @
142−-- 'runTabulation' . 'fromQuery' = id
143−-- 'fromQuery' . 'runTabulation' = id
144−-- @
145−--
146−-- Note however that it produces nonsense when passed a 'Tabulation' that was
147−-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
148−-- will always produce zero rows.
149−runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
150−runTabulation (Tabulation f) = do
151− (mk, a) <- f (Left undefined)
152− case mk of
153− Nothing -> do
154− -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
155− -- invalid SQL, so we use "WHERE NOT TRUE" instead
156− where_ $ not_ true
157− pure (undefined, a)
158− Just k -> pure (k, a)
159−
160−
161−liftQuery :: Query a -> Tabulation k a
162−liftQuery query = Tabulation $ const $ fmap (Nothing,) query
262+-- | Any 'Query' of key-value pairs @(k, a)@ can be a @'Tabulation' k a@.
263+fromQuery :: Query (k, a) -> Tabulation k a
264+fromQuery = Tabulation . const . fmap (first pure)
163265
164266
165−-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
166−-- indexed by one or more of its columns @k@. Some examples:
267+-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.
167268--
168−-- [Tabulation by primary key]:
169−-- @
170−-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
171−-- projectsById = 'tabulate' projectId
172−-- @
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.
173272--
174−-- Note: the nature of primary keys means that each key will be mapped to a
175−-- singleton value in this case.
273+-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
274+-- an explicit set of keys:
176275--
177−-- [Tabulation by other unique key]:
178−-- @
179−-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
180−-- projectsByName = 'tabulate' projectName
181−-- @
276+-- @
277+-- do
278+-- k <- keys
279+-- a <- lookup k tabulation
280+-- pure (k, a)
281+-- @
182282--
183−-- [Tabulation by foreign key (tabulate a child table by parent key)]:
184−-- @
185−-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
186−-- revisionsByProjectId = 'tabulate' revisionProjectId
187−-- @
188−tabulate :: (a -> k) -> a -> Tabulation k a
189−tabulate key a = fromQuery $ pure (key a, a)
190−
191−
192−-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
193−-- one. This means you can filter rows while calculating the key, which is
194−-- useful in conjunction with 'Rel8.Extra.catNulls'.
195−tabulateA :: (a -> Query k) -> a -> Tabulation k a
196−tabulateA key a = fromQuery $ (,a) <$> key a
197−
198−
199−-- | Analgous to 'Data.Map.Strict.fromList'.
200−fromQuery :: Query (k, a) -> Tabulation k a
201−fromQuery = Tabulation . const . fmap (first Just)
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.
288+--
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'.
295+toQuery :: Table Expr k => Tabulation k a -> Query (k, a)
296+toQuery (Tabulation f) = do
297+ (mk, a) <- f mempty
298+ k <- cat mk
299+ pure (k, a)
300+
301+
302+-- | A @'Query' a@ can be treated as a @'Tabulation' k a@ where the given @a@
303+-- values exist at every possible key @k@.
304+liftQuery :: Query a -> Tabulation k a
305+liftQuery = Tabulation . const . fmap (empty,)
202306
203307
204−indexed :: Tabulation k a -> Tabulation k (k, a)
205−indexed (Tabulation query) = Tabulation $ \i ->
206− (\(mk, a) -> (mk, (fromMaybe (either id id i) mk, a))) <$> query i
308+-- | Run a Kleisli arrow in the the 'Query' monad \"through\" a 'Tabulation'.
309+-- Useful for 'Rel8.filter'ing a 'Tabulation'.
310+--
311+-- @
312+-- 'Rel8.filter' ((>=. 30) . userAge) `'through'` usersById
313+-- @
314+through :: (a -> Query b) -> Tabulation k a -> Tabulation k b
315+through f (Tabulation as) = Tabulation $ \p -> do
316+ (k, a) <- as p
317+ b <- f a
318+ pure (k, b)
319+infixr 1 `through`
207320
208321
209−ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
210−ifilter f tabulation = snd <$> do
211− filter (uncurry f) `postbind` indexed tabulation
322+-- | @'lookup' k t@ returns the value(s) at the key @k@ in the tabulation @t@.
323+lookup :: EqTable k => k -> Tabulation k a -> Query a
324+lookup k (Tabulation f) = do
325+ (k', a) <- f p
326+ ensure p k'
327+ pure a
328+ where
329+ p = match (pure k)
212330
213331
214−-- | Map a 'Query' over the input side of a 'Tabulation'.
215−prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
216−prebind f as = Tabulation $ \k -> do
217− a <- as
218− case f a of
219− Tabulation query -> query k
220−infixr 1 `prebind`
332+-- | 'aggregate' aggregates the values within each key of a
333+-- 'Tabulation'. There is an implicit @GROUP BY@ on all the key columns.
334+aggregate :: forall k aggregates exprs.
335+ ( EqTable k
336+ , Aggregates aggregates exprs
337+ )
338+ => Tabulation k aggregates -> Tabulation k exprs
339+aggregate (Tabulation f) = Tabulation $
340+ mapOpaleye (Opaleye.aggregate (keyed haggregator aggregator)) .
341+ fmap (first (fmap (hgroupBy (eqTable @k) . toColumns))) .
342+ f
343+ where
344+ haggregator = dimap fromColumns fromCols aggregator
345+
346+
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'.
351+distinct :: EqTable k => Tabulation k a -> Tabulation k a
352+distinct (Tabulation f) = Tabulation $
353+ mapOpaleye (Opaleye.distinctOnExplicit (key unpackspec) fst) . f
354+
355+
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
359+-- 'some'.
360+order :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
361+order ordering (Tabulation f) =
362+ Tabulation $ mapOpaleye (Opaleye.orderBy ordering') . f
363+ where
364+ Order ordering' = runClown (keyed (Clown ascTable) (Clown ordering))
365+
366+
367+-- $magic
368+--
369+-- Some of the following combinators produce \"magic\" 'Tabulation's. Let's
370+-- use 'count' as an example to demonstrate this concept. Consider
371+-- the following:
372+--
373+-- @
374+-- count $ fromQuery $ values
375+-- [ (lit 'a', lit True)
376+-- , (lit 'a', lit False)
377+-- , (lit 'b', lit True)
378+-- ]
379+-- @
380+--
381+-- You might expect this to be equivalent to the following 'Tabulation':
382+--
383+-- @
384+-- fromQuery $ values
385+-- [ (lit 'a', 2)
386+-- , (lit 'b', 1)
387+-- ]
388+-- @
389+--
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.
393+--
394+-- This means you can do:
395+--
396+-- @
397+-- do
398+-- user <- usersById
399+-- orderCount <- count ordersByUserId
400+-- @
401+--
402+-- To see how many orders a user has (getting @0@ if they have no orders).
221403
222404
223−-- | Map a 'Query' over the output side of a 'Tabulation'.
224−postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
225−postbind f (Tabulation as) = Tabulation $ \i -> do
226− (k, a) <- as i
227− case f a of
228− bs -> do
229− b <- bs
230− pure (k, b)
231−infixr 1 `postbind`
405+-- | 'count' returns a count of how many entries are in the given
406+-- 'Tabulation' at each key.
407+--
408+-- The resulting 'Tabulation' is \"magic\" in that the value @0@ exists at
409+-- every possible key that wasn't in the given 'Tabulation'.
410+count :: EqTable k => Tabulation k a -> Tabulation k (Expr Int64)
411+count =
412+ fmap (maybeTable 0 id) .
413+ optional .
414+ aggregate .
415+ fmap (const countStar)
416+
417+
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'.
421+--
422+-- This is used to implement 'leftAlignWith'.
423+optional :: Tabulation k a -> Tabulation k (MaybeTable Expr a)
424+optional (Tabulation f) = Tabulation $ \p -> case p of
425+ Predicate Nothing -> fmap pure <$> f p
426+ _ -> fmap (\m -> (empty, snd <$> m)) $ Q.optional $ do
427+ (k, a) <- f p
428+ ensure p k
429+ pure (k, a)
430+
431+
432+-- | 'many' aggregates each entry with a particular key into a
433+-- single entry with all of the values contained in a 'ListTable'.
434+--
435+-- 'order' can be used to give this 'ListTable' a defined order.
436+--
437+-- The resulting 'Tabulation' is \"magic\" in that the value
438+-- @'Rel8.listTable []'@ exists at every possible key that wasn't in the given
439+-- 'Tabulation'.
440+many :: (EqTable k, Table Expr a)
441+ => Tabulation k a -> Tabulation k (ListTable Expr a)
442+many =
443+ fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
444+ optional .
445+ aggregate .
446+ fmap (listAgg . toCols)
447+
448+
449+-- | 'some' aggregates each entry with a particular key into a
450+-- single entry with all of the values contained in a 'NonEmptyTable'.
451+--
452+-- 'order' can be used to give this 'NonEmptyTable' a defined order.
453+some :: (EqTable k, Table Expr a)
454+ => Tabulation k a -> Tabulation k (NonEmptyTable Expr a)
455+some =
456+ fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
457+ aggregate .
458+ fmap (nonEmptyAgg . toCols)
459+
460+
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.
464+exists :: Tabulation k a -> Tabulation k (Expr Bool)
465+exists (Tabulation f) = Tabulation $ \p -> case p of
466+ Predicate Nothing -> (true <$) <$> f p
467+ _ -> fmap (empty,) $ Q.exists $ do
468+ (k, _) <- f p
469+ ensure p k
470+
471+
472+-- | 'present' produces a 'Tabulation' where a single @()@ row
473+-- exists for every key that was present in the given 'Tabulation'.
474+--
475+-- This is used to implement 'similarity'.
476+present :: Tabulation k a -> Tabulation k ()
477+present (Tabulation f) = Tabulation $ \p -> do
478+ Q.present $ do
479+ (k, _) <- f p
480+ ensure p k
481+ pure (empty, ())
232482
233483
234−-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
235−-- 'lookup' can and often does contain multiple results.
236−lookup :: EqTable k => k -> Tabulation k a -> Query a
237−lookup key (Tabulation query) = do
238− (mk, a) <- query (Right key)
239− traverse_ (where_ . (key ==:)) mk
240− pure a
484+-- | 'absent' produces a 'Tabulation' where a single @()@ row exists
485+-- at every possible key that absent from the given 'Tabulation'.
486+--
487+-- This is used to implement 'difference'.
488+absent :: Tabulation k a -> Tabulation k ()
489+absent (Tabulation f) = Tabulation $ \p -> do
490+ Q.absent $ do
491+ (k, _) <- f p
492+ ensure p k
493+ pure (empty, ())
241494
242495
243−-- | Analagous to
244−-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
496+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
245497--
246−-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
247−align :: (EqTable k, Table Expr a, Table Expr b)
248− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
498+-- Analogous to 'Data.Semialign.align'.
499+align :: EqTable k
500+ => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
249501align = alignWith id
250502
251503
252−-- | Analagous to
253−-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
504+-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
254505--
255−-- See 'zipWith' and 'align'.
256−alignWith :: (EqTable k, Table Expr a, Table Expr b)
257− => (TheseTable a b -> c)
506+-- Analogous to 'Data.Semialign.alignWith'.
507+alignWith :: EqTable k
508+ => (TheseTable Expr a b -> c)
258509 -> Tabulation k a -> Tabulation k b -> Tabulation k c
259−alignWith f kas kbs = do
260− as <- toQuery kas
261− bs <- toQuery kbs
262− fromQuery $ do
263− tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
264− let
265− k' = theseTable fst fst (const fst) tkab
266− tab = bimap snd snd tkab
267− pure (k', f tab)
268−
269−
270−-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
271−-- This means it will return at least one row for every row in the left
272−-- 'Tabulation', even if there is no corresponding row in the right (hence the
273−-- 'Rel8.MaybeTable').
274−--
275−-- Analagous to
276−-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
510+alignWith 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
513+ let
514+ tab = bimap snd snd tkab
515+ pure (k, f tab)
516+ where
517+ condition (k, _) (k', _) = fromMaybe true (liftA2 (==:) k k')
518+ recover (TheseTable mma@(MaybeTable _ ma) mmb@(MaybeTable _ mb)) =
519+ case extract ma of
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)
525+
526+
527+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
528+--
529+-- Analogous to 'Data.Semialign.rpadZip'.
530+--
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
534+-- use @do@-notation.
277535leftAlign :: EqTable k
278− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
536+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
279537leftAlign = leftAlignWith (,)
280538
281539
282−-- | See 'zipWith' and 'leftAlign'.
540+-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
283541--
284−-- Analagous to
285−-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
542+-- Analogous to 'Data.Semialign.rpadZipWith'.
543+--
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
547+-- use @do@-notation.
286548leftAlignWith :: EqTable k
287− => (a -> MaybeTable b -> c)
549+ => (a -> MaybeTable Expr b -> c)
288550 -> Tabulation k a -> Tabulation k b -> Tabulation k c
289−leftAlignWith f left right = liftA2 f left (optionalTabulation right)
551+leftAlignWith f left right = liftA2 f left (optional right)
290552
291553
292−-- | Analagous to
293−-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
554+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
294555--
295−-- There are multiple correct ways of understanding what this does.
556+-- Analogous to 'Data.Semialign.lpadZip'.
296557--
297−-- You can think of it as @'Data.Map.Strict.intersectionWith'
298−-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
299−-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
300−-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
301−-- values are keys) by getting their cartesian product.
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.
562+rightAlign :: EqTable k
563+ => Tabulation k a -> Tabulation k b -> Tabulation k (MaybeTable Expr a, b)
564+rightAlign = rightAlignWith (,)
565+
566+
567+-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
302568--
303−-- You can think of it as performing a cross product of the underlying 'Query's
304−-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
569+-- Analogous to 'Data.Semialign.lpadZipWith'.
305570--
306−-- You can think of it as a natural join in SQL terms.
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.
575+rightAlignWith :: EqTable k
576+ => (MaybeTable Expr a -> b -> c)
577+ -> Tabulation k a -> Tabulation k b -> Tabulation k c
578+rightAlignWith f left right = liftA2 (flip f) right (optional left)
579+
580+
581+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
307582--
308−-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
309−-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
310−-- the number of values.
583+-- Analagous to 'Data.Semialign.zip'.
584+--
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
587+-- @do@-notation.
311588zip :: EqTable k
312589 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
313590zip = zipWith (,)
314591
315592
316−-- | Analagous to
317−-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
593+-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
594+--
595+-- Analagous to 'Data.Semialign.zipWith'.
318596--
319−-- See 'zip'.
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
599+-- @do@-notation.
320600zipWith :: EqTable k
321601 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
322602zipWith = liftA2
323603
324604
325−-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
326−-- corresponding entry in the right 'Tabulation'. This corresponds to a
327−-- semijoin in relational algebra.
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.
328607--
329−-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
330−-- contains an entry with multiple rows. For 'similarity', the entries in the
331−-- resulting 'Tabulation' will contain the same number of rows as their
332−-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
333−-- each entry would contain the /product/ of the number of rows of their
334−-- respective entries in @x@ and @y@.
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.
335610--
336−-- See 'Rel8.with'.
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
614+-- @do@-notation.
337615similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
338−similarity kas kbs = do
339− as <- toQuery kas
340− bs <- toQuery kbs
341− fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
616+similarity a b = a <* present b
342617
343618
344−-- | 'difference' returns all the entries in the left 'Tabulation' that don't
345−-- exist in the right 'Tabulation'. This corresponds to an antijoin in
346−-- relational algebra.
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.
621+--
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.
347624--
348−-- See 'Rel8.without'.
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
628+-- @do@-notation.
349629difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
350−difference kas kbs = do
351− as <- toQuery kas
352− bs <- toQuery kbs
353− fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
354−
355−
356−aggregateTabulation :: EqTable k
357− => Tabulation k (Aggregate a) -> Tabulation k a
358−aggregateTabulation kas = do
359− as <- toQuery kas
360− fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
361−
362−
363−-- | 'orderTabulation' orders the /values/ of a 'Tabulation' (not the keys).
364−-- In general this is meaningless, but if used together with 'manyTabulation'
365−-- or 'someTabulation', the resulting lists will be ordered according to
366−-- ordering given to 'orderTabulation'.
367−orderTabulation :: Order a -> Tabulation k a -> Tabulation k a
368−orderTabulation ordering (Tabulation as) =
369− Tabulation $ orderBy (snd >$< ordering) . as
370−
371−
372−-- | Turns the given 'Tabulation' from a \"multimap\" into a \"map\". If there
373−-- is more than one value at a particular key, only the first one is kept.
374−-- \"First\" is in general undefined, but 'orderTabulation' can be used to
375−-- make it deterministic.
376−singularize :: (EqTable k, Table Expr a) => Tabulation k a -> Tabulation k a
377−singularize = aggregateTabulation . fmap headAgg
378−
379−
380−optionalTabulation :: EqTable k
381− => Tabulation k a -> Tabulation k (MaybeTable a)
382−optionalTabulation as = Tabulation $ \case
383− Left k -> case as of
384− Tabulation f -> fmap pure <$> f (Left k)
385− Right k -> do
386− ma <- optional $ lookup k as
387− pure (Just k, ma)
388−
389−
390−manyTabulation :: (EqTable k, Table Expr a)
391− => Tabulation k a -> Tabulation k (ListTable a)
392−manyTabulation =
393− fmap (maybeTable mempty id) .
394− optionalTabulation .
395− aggregateTabulation .
396− fmap listAgg
397−
398−
399−someTabulation :: (EqTable k, Table Expr a)
400− => Tabulation k a -> Tabulation k (NonEmptyTable a)
401−someTabulation = aggregateTabulation . fmap nonEmptyAgg
630+difference a b = a <* absent b
402631
403632
404−toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
405−toQuery (Tabulation as) = Tabulation $ \k ->
406− pure (Nothing, first (fromMaybe (either id id k)) <$> as k)
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.
636+peek :: Tabulation k a -> Tabulation k (Either (Query a) (Query (k, a)))
637+peek (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)