git.iko.soy/rel8
on 62f323a help sign in
rel8/src/Rel8/Tabulate.hs
404 lines 13 kB history raw
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
4{-# language MonoLocalBinds #-}
5{-# language ScopedTypeVariables #-}
6{-# language TypeApplications #-}
7{-# language TupleSections #-}
8{-# language UndecidableInstances #-}
10module Rel8.Tabulate
11 ( Tabulation
12 , tabulate
13 , tabulateA
14 , runTabulation
15 , fromQuery
16 , liftQuery
17 , prebind
18 , postbind
19 , indexed
20 , ifilter
21 , lookup
22 , align
23 , alignWith
24 , leftAlign
25 , leftAlignWith
26 , zip
27 , zipWith
28 , similarity
29 , difference
30 , aggregateTabulation
31 , orderTabulation
32 , distinctTabulation
33 , optionalTabulation
34 , manyTabulation
35 , someTabulation
36 )
37where
39-- base
40import Control.Applicative ( liftA2 )
41import Control.Monad ( join, liftM2 )
42import Data.Bifunctor ( bimap, first )
43import Data.Foldable ( traverse_ )
44import Data.Functor.Contravariant ( (>$<) )
45import Data.Maybe ( fromMaybe )
46import Prelude hiding ( filter, lookup, zip, zipWith )
48-- rel8
49import Rel8.Aggregate ( Aggregates )
50import Rel8.Expr ( Expr )
51import Rel8.Order ( Order )
52import Rel8.Query ( Query )
53import Rel8.Query.Aggregate ( aggregate )
54import Rel8.Query.Distinct ( distinctOn )
55import Rel8.Query.Exists ( withBy, withoutBy )
56import Rel8.Query.Filter ( filter, where_ )
57import Rel8.Query.Maybe ( optional )
58import Rel8.Query.Order ( orderBy )
59import Rel8.Query.These ( alignBy )
60import Rel8.Table ( Table, fromColumns, toColumns )
61import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
62import Rel8.Table.Alternative
63 ( AltTable, (<|>:)
64 , AlternativeTable, emptyTable
65 )
66import Rel8.Table.Eq ( EqTable, (==:), eqTable )
67import Rel8.Table.List ( ListTable( ListTable ) )
68import Rel8.Table.Maybe ( MaybeTable, maybeTable )
69import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
70import Rel8.Table.Ord ( OrdTable )
71import Rel8.Table.Order ( ascTable )
72import Rel8.Table.These ( TheseTable, theseTable )
74-- semigroupoids
75import Data.Functor.Apply ( Apply, liftF2 )
76import Data.Functor.Bind ( Bind )
77import qualified Data.Functor.Bind
80-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
81-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
82-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
83--
84-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
85-- be composed with 'Query's with 'prebind' or 'postbind' to form new
86-- 'Tabulation's.
87newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
88 deriving stock Functor
91instance EqTable k => Apply (Tabulation k) where
92 liftF2 = liftA2
95instance EqTable k => Applicative (Tabulation k) where
96 pure = liftQuery . pure
97 liftA2 = liftM2
100instance EqTable k => Bind (Tabulation k) where
101 join = join
104instance EqTable k => Monad (Tabulation k) where
105 Tabulation as >>= f = Tabulation $ \i -> do
106 (mk, a) <- as i
107 case mk of
108 Nothing -> case f a of
109 Tabulation bs -> bs i
110 Just k -> case f a of
111 Tabulation bs -> do
112 (mk', b) <- bs k
113 case mk' of
114 Nothing -> pure (mk, b)
115 Just k' -> do
116 where_ $ k ==: k'
117 pure (mk', b)
120instance EqTable k => AltTable (Tabulation k) where
121 kas <|>: kbs = do
122 as <- toQuery kas
123 bs <- toQuery kbs
124 fromQuery $ as <|>: bs
127instance EqTable k => AlternativeTable (Tabulation k) where
128 emptyTable = fromQuery emptyTable
131instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
132 where
133 (<>) = alignWith (theseTable id id (<>))
136instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
137 where
138 mempty = emptyTable
141runTabulation :: EqTable k => Query k -> Tabulation k a -> Query (k, a)
142runTabulation ks tabulation = do
143 k <- ks
144 a <- lookup k tabulation
145 pure (k, a)
148liftQuery :: Query a -> Tabulation k a
149liftQuery query = Tabulation $ const $ fmap (Nothing,) query
152-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
153-- indexed by one or more of its columns @k@. Some examples:
154--
155-- [Tabulation by primary key]:
156-- @
157-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
158-- projectsById = 'tabulate' projectId
159-- @
160--
161-- Note: the nature of primary keys means that each key will be mapped to a
162-- singleton value in this case.
163--
164-- [Tabulation by other unique key]:
165-- @
166-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
167-- projectsByName = 'tabulate' projectName
168-- @
169--
170-- [Tabulation by foreign key (tabulate a child table by parent key)]:
171-- @
172-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
173-- revisionsByProjectId = 'tabulate' revisionProjectId
174-- @
175tabulate :: (a -> k) -> a -> Tabulation k a
176tabulate key a = fromQuery $ pure (key a, a)
179-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
180-- one. This means you can filter rows while calculating the key, which is
181-- useful in conjunction with 'Rel8.Extra.catNulls'.
182tabulateA :: (a -> Query k) -> a -> Tabulation k a
183tabulateA key a = fromQuery $ (,a) <$> key a
186-- | Analgous to 'Data.Map.Strict.fromList'.
187fromQuery :: Query (k, a) -> Tabulation k a
188fromQuery = Tabulation . const . fmap (first Just)
191indexed :: Tabulation k a -> Tabulation k (k, a)
192indexed (Tabulation query) = Tabulation $ \i ->
193 (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
196ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
197ifilter f tabulation = snd <$> do
198 filter (uncurry f) `postbind` indexed tabulation
201-- | Map a 'Query' over the input side of a 'Tabulation'.
202prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
203prebind f as = Tabulation $ \k -> do
204 a <- as
205 case f a of
206 Tabulation query -> query k
207infixr 1 `prebind`
210-- | Map a 'Query' over the output side of a 'Tabulation'.
211postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
212postbind f (Tabulation as) = Tabulation $ \i -> do
213 (k, a) <- as i
214 case f a of
215 bs -> do
216 b <- bs
217 pure (k, b)
218infixr 1 `postbind`
221-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
222-- 'lookup' can and often does contain multiple results.
223lookup :: EqTable k => k -> Tabulation k a -> Query a
224lookup key (Tabulation query) = do
225 (mk, a) <- query key
226 traverse_ (where_ . (key ==:)) mk
227 pure a
230-- | Analagous to
231-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
232--
233-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
234align :: (EqTable k, Table Expr a, Table Expr b)
235 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
236align = alignWith id
239-- | Analagous to
240-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
241--
242-- See 'zipWith' and 'align'.
243alignWith :: (EqTable k, Table Expr a, Table Expr b)
244 => (TheseTable a b -> c)
245 -> Tabulation k a -> Tabulation k b -> Tabulation k c
246alignWith f kas kbs = do
247 as <- toQuery kas
248 bs <- toQuery kbs
249 fromQuery $ do
250 tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
251 let
252 k' = theseTable fst fst (const fst) tkab
253 tab = bimap snd snd tkab
254 pure (k', f tab)
257-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
258-- This means it will return at least one row for every row in the left
259-- 'Tabulation', even if there is no corresponding row in the right (hence the
260-- 'Rel8.MaybeTable').
261--
262-- Analagous to
263-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
264leftAlign :: EqTable k
265 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
266leftAlign = leftAlignWith (,)
269-- | See 'zipWith' and 'leftAlign'.
270--
271-- Analagous to
272-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
273leftAlignWith :: EqTable k
274 => (a -> MaybeTable b -> c)
275 -> Tabulation k a -> Tabulation k b -> Tabulation k c
276leftAlignWith f left right = liftA2 f left (optionalTabulation right)
279-- | Analagous to
280-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
281--
282-- There are multiple correct ways of understanding what this does.
283--
284-- You can think of it as @'Data.Map.Strict.intersectionWith'
285-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
286-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
287-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
288-- values are keys) by getting their cartesian product.
289--
290-- You can think of it as performing a cross product of the underlying 'Query's
291-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
292--
293-- You can think of it as a natural join in SQL terms.
294--
295-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
296-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
297-- the number of values.
298zip :: EqTable k
299 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
300zip = zipWith (,)
303-- | Analagous to
304-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
305--
306-- See 'zip'.
307zipWith :: EqTable k
308 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
309zipWith = liftA2
312-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
313-- corresponding entry in the right 'Tabulation'. This corresponds to a
314-- semijoin in relational algebra.
315--
316-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
317-- contains an entry with multiple rows. For 'similarity', the entries in the
318-- resulting 'Tabulation' will contain the same number of rows as their
319-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
320-- each entry would contain the /product/ of the number of rows of their
321-- respective entries in @x@ and @y@.
322--
323-- See 'Rel8.with'.
324similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
325similarity kas kbs = do
326 as <- toQuery kas
327 bs <- toQuery kbs
328 fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
331-- | 'difference' returns all the entries in the left 'Tabulation' that don't
332-- exist in the right 'Tabulation'. This corresponds to an antijoin in
333-- relational algebra.
334--
335-- See 'Rel8.without'.
336difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
337difference kas kbs = do
338 as <- toQuery kas
339 bs <- toQuery kbs
340 fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
343aggregateTabulation :: forall k aggregates exprs.
344 ( EqTable k
345 , Aggregates aggregates exprs
346 )
347 => Tabulation k aggregates -> Tabulation k exprs
348aggregateTabulation = mapQuery $
349 fmap (first fromColumns) .
350 aggregate .
351 fmap (first (hgroupBy (eqTable @k) . toColumns))
354-- | 'orderTabulation' orders the /values/ of a 'Tabulation' within each key.
355--
356-- In general this is meaningless, but if used together with 'manyTabulation'
357-- or 'someTabulation', the resulting lists will be ordered according to
358-- ordering given to 'orderTabulation'.
359orderTabulation :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
360orderTabulation ordering = mapQuery $ orderBy ordering'
361 where
362 ordering' = (fst >$< ascTable) <> (snd >$< ordering)
365-- | Turns the given 'Tabulation' from a \"multimap\" into a \"map\". If there
366-- is more than one value at a particular key, only the first one is kept.
367-- \"First\" is in general undefined, but 'orderTabulation' can be used to
368-- make it deterministic.
369distinctTabulation :: EqTable k => Tabulation k a -> Tabulation k a
370distinctTabulation = mapQuery (distinctOn fst)
373optionalTabulation :: EqTable k
374 => Tabulation k a -> Tabulation k (MaybeTable a)
375optionalTabulation as = Tabulation $ \k -> do
376 ma <- optional $ lookup k as
377 pure (Just k, ma)
380manyTabulation :: (EqTable k, Table Expr a)
381 => Tabulation k a -> Tabulation k (ListTable a)
382manyTabulation =
383 fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
384 optionalTabulation .
385 aggregateTabulation .
386 fmap (listAgg . toColumns)
389someTabulation :: (EqTable k, Table Expr a)
390 => Tabulation k a -> Tabulation k (NonEmptyTable a)
391someTabulation =
392 fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
393 aggregateTabulation .
394 fmap (nonEmptyAgg . toColumns)
397mapQuery :: (Query (k, a) -> Query (k, b)) -> Tabulation k a -> Tabulation k b
398mapQuery f (Tabulation query) = Tabulation $ \k ->
399 first Just <$> f (first (fromMaybe k) <$> query k)
402toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
403toQuery (Tabulation as) = Tabulation $ \k ->
404 pure (Nothing, first (fromMaybe k) <$> as k)