@@ -1,254 +1,131 @@
1+{-# language DeriveFunctor #-}
2+{-# language DerivingStrategies #-}
13{-# language FlexibleContexts #-}
2−{-# language MonoLocalBinds #-}
3−{-# language ScopedTypeVariables #-}
4−{-# language StandaloneKindSignatures #-}
5−{-# language TypeApplications #-}
4+{-# language LambdaCase #-}
65{-# language TupleSections #-}
76{-# language UndecidableInstances #-}
87
9−-- | "Rel8.Tabulate" provides an alternative API ('Tabulation') for writing
10−-- queries that complements the main "Rel8" API ('Query').
11−
128module Rel8.Tabulate
13− (
14− Tabulation
15−
16− -- * Interfacing with 'Query's
9+ ( Tabulation
10+ , runTabulation
11+ , tabulate
12+ , tabulateA
1713 , fromQuery
18− , toQuery
1914 , liftQuery
20− , through
15+ , prebind
16+ , postbind
17+ , indexed
18+ , ifilter
2119 , 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
3920 , align
4021 , alignWith
4122 , leftAlign
4223 , leftAlignWith
43− , rightAlign
44− , rightAlignWith
4524 , zip
4625 , zipWith
4726 , similarity
4827 , difference
28+ , aggregateTabulation
29+ , orderTabulation
30+ , singularize
31+ , optionalTabulation
32+ , manyTabulation
33+ , someTabulation
4934 )
5035where
5136
5237-- base
53−import Control.Applicative ( (<|>), empty, liftA2 )
54−import Control.Monad ( liftM2 )
55−import Data.Bifunctor ( Bifunctor, bimap, first, second )
38+import Control.Applicative ( liftA2 )
39+import Control.Monad ( join, liftM2 )
40+import Data.Bifunctor ( bimap, first )
5641import 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 ( 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
42+import Data.Functor.Contravariant ( (>$<) )
43+import Data.Maybe ( fromMaybe )
44+import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
8345
8446-- rel8
85−import Rel8.Aggregate ( Aggregates )
47+import Rel8.Aggregate ( Aggregate )
8648import Rel8.Expr ( Expr )
87−import Rel8.Expr.Aggregate ( countStar )
88−import Rel8.Expr.Bool ( true )
89−import Rel8.Order ( Order( Order ) )
49+import Rel8.Expr.Bool ( not_, true )
50+import Rel8.Order ( Order )
9051import Rel8.Query ( Query )
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 )
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 )
9757import Rel8.Query.These ( alignBy )
98−import Rel8.Table ( Table, fromColumns, toColumns )
99−import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
58+import Rel8.Table ( Table )
59+import Rel8.Table.Aggregate ( groupBy, headAgg, listAgg, nonEmptyAgg )
10060import Rel8.Table.Alternative
10161 ( AltTable, (<|>:)
10262 , AlternativeTable, emptyTable
10363 )
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 )
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 )
11870
11971-- semigroupoids
12072import Data.Functor.Apply ( Apply, liftF2 )
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
73+import Data.Functor.Bind ( Bind )
74+import qualified Data.Functor.Bind
75+import Data.Semigroup.Traversable.Class ( bitraverse1 )
14376
14477
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.
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.
17981--
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))
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
18587
18688
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 (<*>))@
20989instance EqTable k => Apply (Tabulation k) where
21090 liftF2 = liftA2
21191
21292
213−-- | @pure = 'liftQuery' . pure@
21493instance EqTable k => Applicative (Tabulation k) where
21594 pure = liftQuery . pure
21695 liftA2 = liftM2
21796
21897
21998instance EqTable k => Bind (Tabulation k) where
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)
99+ join = join
228100
229101
230102instance EqTable k => Monad (Tabulation k) where
231− (>>=) = (>>-)
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)
232116
233117
234−-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<|>:)@ is
235−-- @unionWith (<>)@.
236118instance EqTable k => AltTable (Tabulation k) where
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
119+ kas <|>: kbs = do
120+ as <- toQuery kas
121+ bs <- toQuery kbs
122+ fromQuery $ as <|>: bs
244123
245124
246125instance EqTable k => AlternativeTable (Tabulation k) where
247− emptyTable = Tabulation $ const $ fmap (empty,) emptyTable
126+ emptyTable = fromQuery emptyTable
248127
249128
250−-- | If @'Tabulation' k a@ is @Map k (NonEmpty a)@, then @(<>)@ is
251−-- @unionWith (liftA2 (<>))@.
252129instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
253130 where
254131 (<>) = alignWith (theseTable id id (<>))
@@ -259,382 +136,271 @@ instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
259136 mempty = emptyTable
260137
261138
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)
265−
266−
267−-- | Convert a @'Tabulation' k a@ back into a 'Query' of key-value pairs.
268−--
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.
272−--
273−-- A safer, more predictable alternative to 'toQuery' is to use 'lookup' with
274−-- an explicit set of keys:
139+-- | This "undoes" 'fromQuery'.
275140--
276141-- @
277−-- do
278−-- k <- keys
279−-- a <- lookup k tabulation
280−-- pure (k, a)
142+-- 'runTabulation' . 'fromQuery' = id
143+-- 'fromQuery' . 'runTabulation' = id
281144-- @
282145--
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,)
306−
307−
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`
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)
320159
321160
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)
161+liftQuery :: Query a -> Tabulation k a
162+liftQuery query = Tabulation $ const $ fmap (Nothing,) query
330163
331164
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
165+-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
166+-- indexed by one or more of its columns @k@. Some examples:
368167--
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:
168+-- [Tabulation by primary key]:
169+-- @
170+-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
171+-- projectsById = 'tabulate' projectId
172+-- @
372173--
373−-- @
374−-- count $ fromQuery $ values
375−-- [ (lit 'a', lit True)
376−-- , (lit 'a', lit False)
377−-- , (lit 'b', lit True)
378−-- ]
379−-- @
174+-- Note: the nature of primary keys means that each key will be mapped to a
175+-- singleton value in this case.
380176--
381−-- You might expect this to be equivalent to the following 'Tabulation':
177+-- [Tabulation by other unique key]:
178+-- @
179+-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
180+-- projectsByName = 'tabulate' projectName
181+-- @
382182--
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).
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)
403190
404191
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, ())
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
482197
483198
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, ())
199+-- | Analgous to 'Data.Map.Strict.fromList'.
200+fromQuery :: Query (k, a) -> Tabulation k a
201+fromQuery = Tabulation . const . fmap (first Just)
202+
203+
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
207+
208+
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
494212
495213
496−-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
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`
221+
222+
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`
232+
233+
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
241+
242+
243+-- | Analagous to
244+-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
497245--
498−-- Analogous to 'Data.Semialign.align'.
499−align :: EqTable k
500− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable Expr a b)
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)
501249align = alignWith id
502250
503251
504−-- | Performs a @NATURAL FULL OUTER JOIN@ based on the common key columns.
252+-- | Analagous to
253+-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
505254--
506−-- Analogous to 'Data.Semialign.alignWith'.
507−alignWith :: EqTable k
508− => (TheseTable Expr a b -> c)
255+-- See 'zipWith' and 'align'.
256+alignWith :: (EqTable k, Table Expr a, Table Expr b)
257+ => (TheseTable a b -> c)
509258 -> Tabulation k a -> Tabulation k b -> Tabulation k c
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.
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).
535277leftAlign :: EqTable k
536− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable Expr b)
278+ => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
537279leftAlign = leftAlignWith (,)
538280
539281
540−-- | Performs a @NATURAL LEFT OUTER JOIN@ based on the common key columns.
282+-- | See 'zipWith' and 'leftAlign'.
541283--
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.
284+-- Analagous to
285+-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
548286leftAlignWith :: EqTable k
549− => (a -> MaybeTable Expr b -> c)
287+ => (a -> MaybeTable b -> c)
550288 -> Tabulation k a -> Tabulation k b -> Tabulation k c
551−leftAlignWith f left right = liftA2 f left (optional right)
289+leftAlignWith f left right = liftA2 f left (optionalTabulation right)
552290
553291
554−-- | Performs a @NATURAL RIGHT OUTER JOIN@ based on the common key columns.
292+-- | Analagous to
293+-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
555294--
556−-- Analogous to 'Data.Semialign.lpadZip'.
295+-- There are multiple correct ways of understanding what this does.
557296--
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.
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.
568302--
569−-- Analogous to 'Data.Semialign.lpadZipWith'.
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.
570305--
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.
306+-- You can think of it as a natural join in SQL terms.
582307--
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.
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.
588311zip :: EqTable k
589312 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
590313zip = zipWith (,)
591314
592315
593−-- | Performs a @NATURAL INNER JOIN@ based on the common key columns.
594−--
595−-- Analagous to 'Data.Semialign.zipWith'.
316+-- | Analagous to
317+-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
596318--
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.
319+-- See 'zip'.
600320zipWith :: EqTable k
601321 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
602322zipWith = liftA2
603323
604324
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.
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.
607328--
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.
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@.
610335--
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.
336+-- See 'Rel8.with'.
615337similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
616−similarity a b = a <* present b
338+similarity kas kbs = do
339+ as <- toQuery kas
340+ bs <- toQuery kbs
341+ fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
617342
618343
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.
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.
624347--
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.
348+-- See 'Rel8.without'.
629349difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
630−difference a b = a <* absent b
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
631402
632403
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)
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)