git.iko.soy/rel8
on b86f445 help sign in
rel8/src/Rel8/Tabulate.hs
393 lines 12 kB history raw
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
4{-# language TupleSections #-}
5{-# language UndecidableInstances #-}
7module Rel8.Tabulate
8 ( Tabulation
9 , tabulate
10 , tabulateA
11 , runTabulation
12 , fromQuery
13 , liftQuery
14 , prebind
15 , postbind
16 , indexed
17 , ifilter
18 , lookup
19 , align
20 , alignWith
21 , leftAlign
22 , leftAlignWith
23 , zip
24 , zipWith
25 , similarity
26 , difference
27 , aggregateTabulation
28 , orderTabulation
29 , distinctTabulation
30 , optionalTabulation
31 , manyTabulation
32 , someTabulation
33 )
34where
36-- base
37import Control.Applicative ( liftA2 )
38import Control.Monad ( join, liftM2 )
39import Data.Bifunctor ( bimap, first )
40import Data.Foldable ( traverse_ )
41import Data.Functor.Contravariant ( (>$<) )
42import Data.Maybe ( fromMaybe )
43import Prelude hiding ( filter, lookup, zip, zipWith )
45-- rel8
46import Rel8.Aggregate ( Aggregate )
47import Rel8.Expr ( Expr )
48import Rel8.Order ( Order )
49import Rel8.Query ( Query )
50import Rel8.Query.Aggregate ( aggregate )
51import Rel8.Query.Distinct ( distinctOn )
52import Rel8.Query.Exists ( withBy, withoutBy )
53import Rel8.Query.Filter ( filter, where_ )
54import Rel8.Query.Maybe ( optional )
55import Rel8.Query.Order ( orderBy )
56import Rel8.Query.These ( alignBy )
57import Rel8.Table ( Table )
58import Rel8.Table.Aggregate ( groupBy, listAgg, nonEmptyAgg )
59import Rel8.Table.Alternative
60 ( AltTable, (<|>:)
61 , AlternativeTable, emptyTable
62 )
63import Rel8.Table.Eq ( EqTable, (==:) )
64import Rel8.Table.List ( ListTable )
65import Rel8.Table.Maybe ( MaybeTable, maybeTable )
66import Rel8.Table.NonEmpty ( NonEmptyTable )
67import Rel8.Table.Ord ( OrdTable )
68import Rel8.Table.Order ( ascTable )
69import Rel8.Table.These ( TheseTable, theseTable )
71-- semigroupoids
72import Data.Functor.Apply ( Apply, liftF2 )
73import Data.Functor.Bind ( Bind )
74import qualified Data.Functor.Bind
75import Data.Semigroup.Traversable.Class ( bitraverse1 )
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.
81--
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.
85newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
86 deriving stock Functor
89instance EqTable k => Apply (Tabulation k) where
90 liftF2 = liftA2
93instance EqTable k => Applicative (Tabulation k) where
94 pure = liftQuery . pure
95 liftA2 = liftM2
98instance EqTable k => Bind (Tabulation k) where
99 join = join
102instance 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 k
111 case mk' of
112 Nothing -> pure (mk, b)
113 Just k' -> do
114 where_ $ k ==: k'
115 pure (mk', b)
118instance EqTable k => AltTable (Tabulation k) where
119 kas <|>: kbs = do
120 as <- toQuery kas
121 bs <- toQuery kbs
122 fromQuery $ as <|>: bs
125instance EqTable k => AlternativeTable (Tabulation k) where
126 emptyTable = fromQuery emptyTable
129instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
130 where
131 (<>) = alignWith (theseTable id id (<>))
134instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
135 where
136 mempty = emptyTable
139runTabulation :: EqTable k => Query k -> Tabulation k a -> Query (k, a)
140runTabulation ks tabulation = do
141 k <- ks
142 a <- lookup k tabulation
143 pure (k, a)
146liftQuery :: Query a -> Tabulation k a
147liftQuery query = Tabulation $ const $ fmap (Nothing,) query
150-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
151-- indexed by one or more of its columns @k@. Some examples:
152--
153-- [Tabulation by primary key]:
154-- @
155-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
156-- projectsById = 'tabulate' projectId
157-- @
158--
159-- Note: the nature of primary keys means that each key will be mapped to a
160-- singleton value in this case.
161--
162-- [Tabulation by other unique key]:
163-- @
164-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
165-- projectsByName = 'tabulate' projectName
166-- @
167--
168-- [Tabulation by foreign key (tabulate a child table by parent key)]:
169-- @
170-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
171-- revisionsByProjectId = 'tabulate' revisionProjectId
172-- @
173tabulate :: (a -> k) -> a -> Tabulation k a
174tabulate key a = fromQuery $ pure (key a, a)
177-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
178-- one. This means you can filter rows while calculating the key, which is
179-- useful in conjunction with 'Rel8.Extra.catNulls'.
180tabulateA :: (a -> Query k) -> a -> Tabulation k a
181tabulateA key a = fromQuery $ (,a) <$> key a
184-- | Analgous to 'Data.Map.Strict.fromList'.
185fromQuery :: Query (k, a) -> Tabulation k a
186fromQuery = Tabulation . const . fmap (first Just)
189indexed :: Tabulation k a -> Tabulation k (k, a)
190indexed (Tabulation query) = Tabulation $ \i ->
191 (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
194ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
195ifilter f tabulation = snd <$> do
196 filter (uncurry f) `postbind` indexed tabulation
199-- | Map a 'Query' over the input side of a 'Tabulation'.
200prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
201prebind f as = Tabulation $ \k -> do
202 a <- as
203 case f a of
204 Tabulation query -> query k
205infixr 1 `prebind`
208-- | Map a 'Query' over the output side of a 'Tabulation'.
209postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
210postbind f (Tabulation as) = Tabulation $ \i -> do
211 (k, a) <- as i
212 case f a of
213 bs -> do
214 b <- bs
215 pure (k, b)
216infixr 1 `postbind`
219-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
220-- 'lookup' can and often does contain multiple results.
221lookup :: EqTable k => k -> Tabulation k a -> Query a
222lookup key (Tabulation query) = do
223 (mk, a) <- query key
224 traverse_ (where_ . (key ==:)) mk
225 pure a
228-- | Analagous to
229-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
230--
231-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
232align :: (EqTable k, Table Expr a, Table Expr b)
233 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
234align = alignWith id
237-- | Analagous to
238-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
239--
240-- See 'zipWith' and 'align'.
241alignWith :: (EqTable k, Table Expr a, Table Expr b)
242 => (TheseTable a b -> c)
243 -> Tabulation k a -> Tabulation k b -> Tabulation k c
244alignWith f kas kbs = do
245 as <- toQuery kas
246 bs <- toQuery kbs
247 fromQuery $ do
248 tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
249 let
250 k' = theseTable fst fst (const fst) tkab
251 tab = bimap snd snd tkab
252 pure (k', f tab)
255-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
256-- This means it will return at least one row for every row in the left
257-- 'Tabulation', even if there is no corresponding row in the right (hence the
258-- 'Rel8.MaybeTable').
259--
260-- Analagous to
261-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
262leftAlign :: EqTable k
263 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
264leftAlign = leftAlignWith (,)
267-- | See 'zipWith' and 'leftAlign'.
268--
269-- Analagous to
270-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
271leftAlignWith :: EqTable k
272 => (a -> MaybeTable b -> c)
273 -> Tabulation k a -> Tabulation k b -> Tabulation k c
274leftAlignWith f left right = liftA2 f left (optionalTabulation right)
277-- | Analagous to
278-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
279--
280-- There are multiple correct ways of understanding what this does.
281--
282-- You can think of it as @'Data.Map.Strict.intersectionWith'
283-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
284-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
285-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
286-- values are keys) by getting their cartesian product.
287--
288-- You can think of it as performing a cross product of the underlying 'Query's
289-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
290--
291-- You can think of it as a natural join in SQL terms.
292--
293-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
294-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
295-- the number of values.
296zip :: EqTable k
297 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
298zip = zipWith (,)
301-- | Analagous to
302-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
303--
304-- See 'zip'.
305zipWith :: EqTable k
306 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
307zipWith = liftA2
310-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
311-- corresponding entry in the right 'Tabulation'. This corresponds to a
312-- semijoin in relational algebra.
313--
314-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
315-- contains an entry with multiple rows. For 'similarity', the entries in the
316-- resulting 'Tabulation' will contain the same number of rows as their
317-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
318-- each entry would contain the /product/ of the number of rows of their
319-- respective entries in @x@ and @y@.
320--
321-- See 'Rel8.with'.
322similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
323similarity kas kbs = do
324 as <- toQuery kas
325 bs <- toQuery kbs
326 fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
329-- | 'difference' returns all the entries in the left 'Tabulation' that don't
330-- exist in the right 'Tabulation'. This corresponds to an antijoin in
331-- relational algebra.
332--
333-- See 'Rel8.without'.
334difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
335difference kas kbs = do
336 as <- toQuery kas
337 bs <- toQuery kbs
338 fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
341aggregateTabulation :: EqTable k
342 => Tabulation k (Aggregate a) -> Tabulation k a
343aggregateTabulation = mapQuery (aggregate . fmap (bitraverse1 groupBy id))
346-- | 'orderTabulation' orders the /values/ of a 'Tabulation' within each key.
347--
348-- In general this is meaningless, but if used together with 'manyTabulation'
349-- or 'someTabulation', the resulting lists will be ordered according to
350-- ordering given to 'orderTabulation'.
351orderTabulation :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
352orderTabulation ordering = mapQuery $ orderBy ordering'
353 where
354 ordering' = (fst >$< ascTable) <> (snd >$< ordering)
357-- | Turns the given 'Tabulation' from a \"multimap\" into a \"map\". If there
358-- is more than one value at a particular key, only the first one is kept.
359-- \"First\" is in general undefined, but 'orderTabulation' can be used to
360-- make it deterministic.
361distinctTabulation :: EqTable k => Tabulation k a -> Tabulation k a
362distinctTabulation = mapQuery (distinctOn fst)
365optionalTabulation :: EqTable k
366 => Tabulation k a -> Tabulation k (MaybeTable a)
367optionalTabulation as = Tabulation $ \k -> do
368 ma <- optional $ lookup k as
369 pure (Just k, ma)
372manyTabulation :: (EqTable k, Table Expr a)
373 => Tabulation k a -> Tabulation k (ListTable a)
374manyTabulation =
375 fmap (maybeTable mempty id) .
376 optionalTabulation .
377 aggregateTabulation .
378 fmap listAgg
381someTabulation :: (EqTable k, Table Expr a)
382 => Tabulation k a -> Tabulation k (NonEmptyTable a)
383someTabulation = aggregateTabulation . fmap nonEmptyAgg
386mapQuery :: (Query (k, a) -> Query (k, b)) -> Tabulation k a -> Tabulation k b
387mapQuery f (Tabulation query) = Tabulation $ \k ->
388 first Just <$> f (first (fromMaybe k) <$> query k)
391toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
392toQuery (Tabulation as) = Tabulation $ \k ->
393 pure (Nothing, first (fromMaybe k) <$> as k)