git.iko.soy/rel8
on dc69cca help sign in
rel8/src/Rel8/Tabulate.hs
356 lines 11 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 , optionalTabulation
28 , manyTabulation
29 , someTabulation
30 )
31where
33-- base
34import Control.Applicative ( liftA2 )
35import Control.Monad ( join, liftM2 )
36import Data.Bifunctor ( bimap, first )
37import Data.Foldable ( traverse_ )
38import Data.Maybe ( fromMaybe )
39import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
41-- rel8
42import Rel8.Aggregate ( Aggregate )
43import Rel8.Expr ( Expr )
44import Rel8.Expr.Bool ( not_, true )
45import Rel8.Query ( Query )
46import Rel8.Query.Aggregate ( aggregate )
47import Rel8.Query.Exists ( withBy, withoutBy )
48import Rel8.Query.Filter ( filter, where_ )
49import Rel8.Query.Maybe ( optional )
50import Rel8.Query.These ( alignBy )
51import Rel8.Table ( Table )
52import Rel8.Table.Aggregate ( groupBy, listAgg, nonEmptyAgg )
53import Rel8.Table.Eq ( EqTable, (==:) )
54import Rel8.Table.List ( ListTable )
55import Rel8.Table.Maybe ( MaybeTable, maybeTable )
56import Rel8.Table.NonEmpty ( NonEmptyTable )
57import Rel8.Table.These ( TheseTable, theseTable )
58import Rel8.Table.Undefined ( undefined )
60-- semigroupoids
61import Data.Functor.Apply ( Apply, liftF2 )
62import Data.Functor.Bind ( Bind )
63import qualified Data.Functor.Bind
64import Data.Semigroup.Traversable.Class ( bitraverse1 )
67-- | @'Tabulation' k a@ is denotionally a @MultiMap k a@ — a @Map@ where each
68-- key @k@ corresponds to potentially multiple @a@ (i.e., @'Query' a@). This
69-- @MultiMap@ supports 'lookup' and other operations you would expect it to.
70--
71-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
72-- be composed with 'Query's with 'prebind' or 'postbind' to form new
73-- 'Tabulation's.
74newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
75 deriving stock Functor
78instance EqTable k => Apply (Tabulation k) where
79 liftF2 = liftA2
82instance EqTable k => Applicative (Tabulation k) where
83 pure = liftQuery . pure
84 liftA2 = liftM2
87instance EqTable k => Bind (Tabulation k) where
88 join = join
91instance EqTable k => Monad (Tabulation k) where
92 Tabulation as >>= f = Tabulation $ \i -> do
93 (mk, a) <- as i
94 case mk of
95 Nothing -> case f a of
96 Tabulation bs -> bs i
97 Just k -> case f a of
98 Tabulation bs -> do
99 (mk', b) <- bs k
100 case mk' of
101 Nothing -> pure (mk, b)
102 Just k' -> do
103 where_ $ k ==: k'
104 pure (mk', b)
107-- | This "undoes" 'fromQuery'.
108--
109-- @
110-- 'runTabulation' . 'fromQuery' = id
111-- 'fromQuery' . 'runTabulation' = id
112-- @
113--
114-- Note however that it produces nonsense when passed a 'Tabulation' that was
115-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
116-- will always produce zero rows.
117runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
118runTabulation (Tabulation f) = do
119 (mk, a) <- f i
120 case mk of
121 Nothing -> do
122 -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
123 -- invalid SQL, so we use "WHERE NOT TRUE" instead
124 where_ $ not_ true
125 pure (i, a)
126 Just k -> pure (k, a)
127 where
128 i = undefined
131liftQuery :: Query a -> Tabulation k a
132liftQuery query = Tabulation $ const $ fmap (Nothing,) query
135-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
136-- indexed by one or more of its columns @k@. Some examples:
137--
138-- [Tabulation by primary key]:
139-- @
140-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
141-- projectsById = 'tabulate' projectId
142-- @
143--
144-- Note: the nature of primary keys means that each key will be mapped to a
145-- singleton value in this case.
146--
147-- [Tabulation by other unique key]:
148-- @
149-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
150-- projectsByName = 'tabulate' projectName
151-- @
152--
153-- [Tabulation by foreign key (tabulate a child table by parent key)]:
154-- @
155-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
156-- revisionsByProjectId = 'tabulate' revisionProjectId
157-- @
158tabulate :: (a -> k) -> a -> Tabulation k a
159tabulate key a = fromQuery $ pure (key a, a)
162-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
163-- one. This means you can filter rows while calculating the key, which is
164-- useful in conjunction with 'Rel8.Extra.catNulls'.
165tabulateA :: (a -> Query k) -> a -> Tabulation k a
166tabulateA key a = fromQuery $ (,a) <$> key a
169-- | Analgous to 'Data.Map.Strict.fromList'.
170fromQuery :: Query (k, a) -> Tabulation k a
171fromQuery = Tabulation . const . fmap (first Just)
174indexed :: Tabulation k a -> Tabulation k (k, a)
175indexed (Tabulation query) = Tabulation $ \i ->
176 (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
179ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
180ifilter f tabulation = snd <$> do
181 filter (uncurry f) `postbind` indexed tabulation
184-- | Map a 'Query' over the input side of a 'Tabulation'.
185prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
186prebind f as = Tabulation $ \k -> do
187 a <- as
188 case f a of
189 Tabulation query -> query k
190infixr 1 `prebind`
193-- | Map a 'Query' over the output side of a 'Tabulation'.
194postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
195postbind f (Tabulation as) = Tabulation $ \i -> do
196 (k, a) <- as i
197 case f a of
198 bs -> do
199 b <- bs
200 pure (k, b)
201infixr 1 `postbind`
204-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
205-- 'lookup' can and often does contain multiple results.
206lookup :: EqTable k => k -> Tabulation k a -> Query a
207lookup key (Tabulation query) = do
208 (mk, a) <- query key
209 traverse_ (where_ . (key ==:)) mk
210 pure a
213-- | Analagous to
214-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
215--
216-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
217align :: (EqTable k, Table Expr a, Table Expr b)
218 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
219align = alignWith id
222-- | Analagous to
223-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
224--
225-- See 'zipWith' and 'align'.
226alignWith :: (EqTable k, Table Expr a, Table Expr b)
227 => (TheseTable a b -> c)
228 -> Tabulation k a -> Tabulation k b -> Tabulation k c
229alignWith f kas kbs = do
230 as <- toQuery kas
231 bs <- toQuery kbs
232 fromQuery $ do
233 tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
234 let
235 k' = theseTable fst fst (const fst) tkab
236 tab = bimap snd snd tkab
237 pure (k', f tab)
240-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
241-- This means it will return at least one row for every row in the left
242-- 'Tabulation', even if there is no corresponding row in the right (hence the
243-- 'Rel8.MaybeTable').
244--
245-- Analagous to
246-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
247leftAlign :: EqTable k
248 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
249leftAlign = leftAlignWith (,)
252-- | See 'zipWith' and 'leftAlign'.
253--
254-- Analagous to
255-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
256leftAlignWith :: EqTable k
257 => (a -> MaybeTable b -> c)
258 -> Tabulation k a -> Tabulation k b -> Tabulation k c
259leftAlignWith f left right = liftA2 f left (optionalTabulation right)
262-- | Analagous to
263-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
264--
265-- There are multiple correct ways of understanding what this does.
266--
267-- You can think of it as @'Data.Map.Strict.intersectionWith'
268-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
269-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
270-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
271-- values are keys) by getting their cartesian product.
272--
273-- You can think of it as performing a cross product of the underlying 'Query's
274-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
275--
276-- You can think of it as a natural join in SQL terms.
277--
278-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
279-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
280-- the number of values.
281zip :: EqTable k
282 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
283zip = zipWith (,)
286-- | Analagous to
287-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
288--
289-- See 'zip'.
290zipWith :: EqTable k
291 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
292zipWith = liftA2
295-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
296-- corresponding entry in the right 'Tabulation'. This corresponds to a
297-- semijoin in relational algebra.
298--
299-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
300-- contains an entry with multiple rows. For 'similarity', the entries in the
301-- resulting 'Tabulation' will contain the same number of rows as their
302-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
303-- each entry would contain the /product/ of the number of rows of their
304-- respective entries in @x@ and @y@.
305--
306-- See 'Rel8.with'.
307similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
308similarity kas kbs = do
309 as <- toQuery kas
310 bs <- toQuery kbs
311 fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
314-- | 'difference' returns all the entries in the left 'Tabulation' that don't
315-- exist in the right 'Tabulation'. This corresponds to an antijoin in
316-- relational algebra.
317--
318-- See 'Rel8.without'.
319difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
320difference kas kbs = do
321 as <- toQuery kas
322 bs <- toQuery kbs
323 fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
326aggregateTabulation :: EqTable k
327 => Tabulation k (Aggregate a) -> Tabulation k a
328aggregateTabulation kas = do
329 as <- toQuery kas
330 fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
333optionalTabulation :: EqTable k
334 => Tabulation k a -> Tabulation k (MaybeTable a)
335optionalTabulation as = Tabulation $ \k -> do
336 ma <- optional $ lookup k as
337 pure (Just k, ma)
340manyTabulation :: (EqTable k, Table Expr a)
341 => Tabulation k a -> Tabulation k (ListTable a)
342manyTabulation =
343 fmap (maybeTable mempty id) .
344 optionalTabulation .
345 aggregateTabulation .
346 fmap listAgg
349someTabulation :: (EqTable k, Table Expr a)
350 => Tabulation k a -> Tabulation k (NonEmptyTable a)
351someTabulation = aggregateTabulation . fmap nonEmptyAgg
354toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
355toQuery (Tabulation as) = Tabulation $ \k ->
356 pure (Nothing, first (fromMaybe k) <$> as k)