git.iko.soy/rel8
on 5a45f67 help sign in
rel8/src/Rel8/Tabulate.hs
369 lines 12 kB history raw
1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
4{-# language TupleSections #-}
6module Rel8.Tabulate
7 ( Tabulation
8 , runTabulation
9 , tabulate
10 , tabulateA
11 , fromQuery
12 , liftQuery
13 , prebind
14 , postbind
15 , indexed
16 , ifilter
17 , lookup
18 , align
19 , alignWith
20 , leftAlign
21 , leftAlignWith
22 , zip
23 , zipWith
24 , similarity
25 , difference
26 , aggregateTabulation
27 , orderTabulation
28 , optionalTabulation
29 , manyTabulation
30 , someTabulation
31 )
32where
34-- base
35import Control.Applicative ( liftA2 )
36import Control.Monad ( join, liftM2 )
37import Data.Bifunctor ( bimap, first )
38import Data.Foldable ( traverse_ )
39import Data.Functor.Contravariant ( (>$<) )
40import Data.Maybe ( fromMaybe )
41import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
43-- rel8
44import Rel8.Aggregate ( Aggregate )
45import Rel8.Expr ( Expr )
46import Rel8.Expr.Bool ( not_, true )
47import Rel8.Order ( Order )
48import Rel8.Query ( Query )
49import Rel8.Query.Aggregate ( aggregate )
50import Rel8.Query.Exists ( withBy, withoutBy )
51import Rel8.Query.Filter ( filter, where_ )
52import Rel8.Query.Maybe ( optional )
53import Rel8.Query.Order ( orderBy )
54import Rel8.Query.These ( alignBy )
55import Rel8.Table ( Table )
56import Rel8.Table.Aggregate ( groupBy, listAgg, nonEmptyAgg )
57import Rel8.Table.Eq ( EqTable, (==:) )
58import Rel8.Table.List ( ListTable )
59import Rel8.Table.Maybe ( MaybeTable, maybeTable )
60import Rel8.Table.NonEmpty ( NonEmptyTable )
61import Rel8.Table.These ( TheseTable, theseTable )
62import Rel8.Table.Undefined ( undefined )
64-- semigroupoids
65import Data.Functor.Apply ( Apply, liftF2 )
66import Data.Functor.Bind ( Bind )
67import qualified Data.Functor.Bind
68import Data.Semigroup.Traversable.Class ( bitraverse1 )
71-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
72-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
73-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
74--
75-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
76-- be composed with 'Query's with 'prebind' or 'postbind' to form new
77-- 'Tabulation's.
78newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
79 deriving stock Functor
82instance EqTable k => Apply (Tabulation k) where
83 liftF2 = liftA2
86instance EqTable k => Applicative (Tabulation k) where
87 pure = liftQuery . pure
88 liftA2 = liftM2
91instance EqTable k => Bind (Tabulation k) where
92 join = join
95instance EqTable k => Monad (Tabulation k) where
96 Tabulation as >>= f = Tabulation $ \i -> do
97 (mk, a) <- as i
98 case mk of
99 Nothing -> case f a of
100 Tabulation bs -> bs i
101 Just k -> case f a of
102 Tabulation bs -> do
103 (mk', b) <- bs k
104 case mk' of
105 Nothing -> pure (mk, b)
106 Just k' -> do
107 where_ $ k ==: k'
108 pure (mk', b)
111-- | This "undoes" 'fromQuery'.
112--
113-- @
114-- 'runTabulation' . 'fromQuery' = id
115-- 'fromQuery' . 'runTabulation' = id
116-- @
117--
118-- Note however that it produces nonsense when passed a 'Tabulation' that was
119-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
120-- will always produce zero rows.
121runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
122runTabulation (Tabulation f) = do
123 (mk, a) <- f i
124 case mk of
125 Nothing -> do
126 -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
127 -- invalid SQL, so we use "WHERE NOT TRUE" instead
128 where_ $ not_ true
129 pure (i, a)
130 Just k -> pure (k, a)
131 where
132 i = undefined
135liftQuery :: Query a -> Tabulation k a
136liftQuery query = Tabulation $ const $ fmap (Nothing,) query
139-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
140-- indexed by one or more of its columns @k@. Some examples:
141--
142-- [Tabulation by primary key]:
143-- @
144-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
145-- projectsById = 'tabulate' projectId
146-- @
147--
148-- Note: the nature of primary keys means that each key will be mapped to a
149-- singleton value in this case.
150--
151-- [Tabulation by other unique key]:
152-- @
153-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
154-- projectsByName = 'tabulate' projectName
155-- @
156--
157-- [Tabulation by foreign key (tabulate a child table by parent key)]:
158-- @
159-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
160-- revisionsByProjectId = 'tabulate' revisionProjectId
161-- @
162tabulate :: (a -> k) -> a -> Tabulation k a
163tabulate key a = fromQuery $ pure (key a, a)
166-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
167-- one. This means you can filter rows while calculating the key, which is
168-- useful in conjunction with 'Rel8.Extra.catNulls'.
169tabulateA :: (a -> Query k) -> a -> Tabulation k a
170tabulateA key a = fromQuery $ (,a) <$> key a
173-- | Analgous to 'Data.Map.Strict.fromList'.
174fromQuery :: Query (k, a) -> Tabulation k a
175fromQuery = Tabulation . const . fmap (first Just)
178indexed :: Tabulation k a -> Tabulation k (k, a)
179indexed (Tabulation query) = Tabulation $ \i ->
180 (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
183ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
184ifilter f tabulation = snd <$> do
185 filter (uncurry f) `postbind` indexed tabulation
188-- | Map a 'Query' over the input side of a 'Tabulation'.
189prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
190prebind f as = Tabulation $ \k -> do
191 a <- as
192 case f a of
193 Tabulation query -> query k
194infixr 1 `prebind`
197-- | Map a 'Query' over the output side of a 'Tabulation'.
198postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
199postbind f (Tabulation as) = Tabulation $ \i -> do
200 (k, a) <- as i
201 case f a of
202 bs -> do
203 b <- bs
204 pure (k, b)
205infixr 1 `postbind`
208-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
209-- 'lookup' can and often does contain multiple results.
210lookup :: EqTable k => k -> Tabulation k a -> Query a
211lookup key (Tabulation query) = do
212 (mk, a) <- query key
213 traverse_ (where_ . (key ==:)) mk
214 pure a
217-- | Analagous to
218-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
219--
220-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
221align :: (EqTable k, Table Expr a, Table Expr b)
222 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
223align = alignWith id
226-- | Analagous to
227-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
228--
229-- See 'zipWith' and 'align'.
230alignWith :: (EqTable k, Table Expr a, Table Expr b)
231 => (TheseTable a b -> c)
232 -> Tabulation k a -> Tabulation k b -> Tabulation k c
233alignWith f kas kbs = do
234 as <- toQuery kas
235 bs <- toQuery kbs
236 fromQuery $ do
237 tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
238 let
239 k' = theseTable fst fst (const fst) tkab
240 tab = bimap snd snd tkab
241 pure (k', f tab)
244-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
245-- This means it will return at least one row for every row in the left
246-- 'Tabulation', even if there is no corresponding row in the right (hence the
247-- 'Rel8.MaybeTable').
248--
249-- Analagous to
250-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
251leftAlign :: EqTable k
252 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
253leftAlign = leftAlignWith (,)
256-- | See 'zipWith' and 'leftAlign'.
257--
258-- Analagous to
259-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
260leftAlignWith :: EqTable k
261 => (a -> MaybeTable b -> c)
262 -> Tabulation k a -> Tabulation k b -> Tabulation k c
263leftAlignWith f left right = liftA2 f left (optionalTabulation right)
266-- | Analagous to
267-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
268--
269-- There are multiple correct ways of understanding what this does.
270--
271-- You can think of it as @'Data.Map.Strict.intersectionWith'
272-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
273-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
274-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
275-- values are keys) by getting their cartesian product.
276--
277-- You can think of it as performing a cross product of the underlying 'Query's
278-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
279--
280-- You can think of it as a natural join in SQL terms.
281--
282-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
283-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
284-- the number of values.
285zip :: EqTable k
286 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
287zip = zipWith (,)
290-- | Analagous to
291-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
292--
293-- See 'zip'.
294zipWith :: EqTable k
295 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
296zipWith = liftA2
299-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
300-- corresponding entry in the right 'Tabulation'. This corresponds to a
301-- semijoin in relational algebra.
302--
303-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
304-- contains an entry with multiple rows. For 'similarity', the entries in the
305-- resulting 'Tabulation' will contain the same number of rows as their
306-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
307-- each entry would contain the /product/ of the number of rows of their
308-- respective entries in @x@ and @y@.
309--
310-- See 'Rel8.with'.
311similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
312similarity kas kbs = do
313 as <- toQuery kas
314 bs <- toQuery kbs
315 fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
318-- | 'difference' returns all the entries in the left 'Tabulation' that don't
319-- exist in the right 'Tabulation'. This corresponds to an antijoin in
320-- relational algebra.
321--
322-- See 'Rel8.without'.
323difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
324difference kas kbs = do
325 as <- toQuery kas
326 bs <- toQuery kbs
327 fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
330aggregateTabulation :: EqTable k
331 => Tabulation k (Aggregate a) -> Tabulation k a
332aggregateTabulation kas = do
333 as <- toQuery kas
334 fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
337-- | 'orderTabulation' orders the /values/ of a 'Tabulation' (not the keys).
338-- In general this is meaningless, but if used together with 'manyTabulation'
339-- or 'someTabulation', the resulting lists will be ordered according to
340-- ordering given to 'orderTabulation'.
341orderTabulation :: Order a -> Tabulation k a -> Tabulation k a
342orderTabulation ordering (Tabulation as) =
343 Tabulation $ orderBy (snd >$< ordering) . as
346optionalTabulation :: EqTable k
347 => Tabulation k a -> Tabulation k (MaybeTable a)
348optionalTabulation as = Tabulation $ \k -> do
349 ma <- optional $ lookup k as
350 pure (Just k, ma)
353manyTabulation :: (EqTable k, Table Expr a)
354 => Tabulation k a -> Tabulation k (ListTable a)
355manyTabulation =
356 fmap (maybeTable mempty id) .
357 optionalTabulation .
358 aggregateTabulation .
359 fmap listAgg
362someTabulation :: (EqTable k, Table Expr a)
363 => Tabulation k a -> Tabulation k (NonEmptyTable a)
364someTabulation = aggregateTabulation . fmap nonEmptyAgg
367toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
368toQuery (Tabulation as) = Tabulation $ \k ->
369 pure (Nothing, first (fromMaybe k) <$> as k)