@@ -1,404 +0,0 @@
1−{-# language DeriveFunctor #-}
2−{-# language DerivingStrategies #-}
3−{-# language FlexibleContexts #-}
4−{-# language MonoLocalBinds #-}
5−{-# language ScopedTypeVariables #-}
6−{-# language TypeApplications #-}
7−{-# language TupleSections #-}
8−{-# language UndecidableInstances #-}
30− , aggregateTabulation
40−import Control.Applicative ( liftA2 )
41−import Control.Monad ( join, liftM2 )
42−import Data.Bifunctor ( bimap, first )
43−import Data.Foldable ( traverse_ )
44−import Data.Functor.Contravariant ( (>$<) )
45−import Data.Maybe ( fromMaybe )
46−import Prelude hiding ( filter, lookup, zip, zipWith )
49−import Rel8.Aggregate ( Aggregates )
50−import Rel8.Expr ( Expr )
51−import Rel8.Order ( Order )
52−import Rel8.Query ( Query )
53−import Rel8.Query.Aggregate ( aggregate )
54−import Rel8.Query.Distinct ( distinctOn )
55−import Rel8.Query.Exists ( withBy, withoutBy )
56−import Rel8.Query.Filter ( filter, where_ )
57−import Rel8.Query.Maybe ( optional )
58−import Rel8.Query.Order ( orderBy )
59−import Rel8.Query.These ( alignBy )
60−import Rel8.Table ( Table, fromColumns, toColumns )
61−import Rel8.Table.Aggregate ( hgroupBy, listAgg, nonEmptyAgg )
62−import Rel8.Table.Alternative
64− , AlternativeTable, emptyTable
66−import Rel8.Table.Eq ( EqTable, (==:), eqTable )
67−import Rel8.Table.List ( ListTable( ListTable ) )
68−import Rel8.Table.Maybe ( MaybeTable, maybeTable )
69−import Rel8.Table.NonEmpty ( NonEmptyTable( NonEmptyTable ) )
70−import Rel8.Table.Ord ( OrdTable )
71−import Rel8.Table.Order ( ascTable )
72−import Rel8.Table.These ( TheseTable, theseTable )
75−import Data.Functor.Apply ( Apply, liftF2 )
76−import Data.Functor.Bind ( Bind )
77−import 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.
84−-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
85−-- be composed with 'Query's with 'prebind' or 'postbind' to form new
87−newtype Tabulation k a = Tabulation (k -> Query (Maybe k, a))
88− deriving stock Functor
91−instance EqTable k => Apply (Tabulation k) where
95−instance EqTable k => Applicative (Tabulation k) where
96− pure = liftQuery . pure
100−instance EqTable k => Bind (Tabulation k) where
104−instance EqTable k => Monad (Tabulation k) where
105− Tabulation as >>= f = Tabulation $ \i -> do
108− Nothing -> case f a of
109− Tabulation bs -> bs i
110− Just k -> case f a of
114− Nothing -> pure (mk, b)
120−instance EqTable k => AltTable (Tabulation k) where
124− fromQuery $ as <|>: bs
127−instance EqTable k => AlternativeTable (Tabulation k) where
128− emptyTable = fromQuery emptyTable
131−instance (EqTable k, Table Expr a, Semigroup a) => Semigroup (Tabulation k a)
133− (<>) = alignWith (theseTable id id (<>))
136−instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
141−runTabulation :: EqTable k => Query k -> Tabulation k a -> Query (k, a)
142−runTabulation ks tabulation = do
144− a <- lookup k tabulation
148−liftQuery :: Query a -> Tabulation k a
149−liftQuery 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:
155−-- [Tabulation by primary key]:
157−-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
158−-- projectsById = 'tabulate' projectId
161−-- Note: the nature of primary keys means that each key will be mapped to a
162−-- singleton value in this case.
164−-- [Tabulation by other unique key]:
166−-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
167−-- projectsByName = 'tabulate' projectName
170−-- [Tabulation by foreign key (tabulate a child table by parent key)]:
172−-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
173−-- revisionsByProjectId = 'tabulate' revisionProjectId
175−tabulate :: (a -> k) -> a -> Tabulation k a
176−tabulate 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'.
182−tabulateA :: (a -> Query k) -> a -> Tabulation k a
183−tabulateA key a = fromQuery $ (,a) <$> key a
186−-- | Analgous to 'Data.Map.Strict.fromList'.
187−fromQuery :: Query (k, a) -> Tabulation k a
188−fromQuery = Tabulation . const . fmap (first Just)
191−indexed :: Tabulation k a -> Tabulation k (k, a)
192−indexed (Tabulation query) = Tabulation $ \i ->
193− (\(mk, a) -> (mk, (fromMaybe i mk, a))) <$> query i
196−ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
197−ifilter f tabulation = snd <$> do
198− filter (uncurry f) `postbind` indexed tabulation
201−-- | Map a 'Query' over the input side of a 'Tabulation'.
202−prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
203−prebind f as = Tabulation $ \k -> do
206− Tabulation query -> query k
210−-- | Map a 'Query' over the output side of a 'Tabulation'.
211−postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
212−postbind f (Tabulation as) = Tabulation $ \i -> do
221−-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
222−-- 'lookup' can and often does contain multiple results.
223−lookup :: EqTable k => k -> Tabulation k a -> Query a
224−lookup key (Tabulation query) = do
225− (mk, a) <- query key
226− traverse_ (where_ . (key ==:)) mk
231−-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
233−-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
234−align :: (EqTable k, Table Expr a, Table Expr b)
235− => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
240−-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
242−-- See 'zipWith' and 'align'.
243−alignWith :: (EqTable k, Table Expr a, Table Expr b)
244− => (TheseTable a b -> c)
245− -> Tabulation k a -> Tabulation k b -> Tabulation k c
246−alignWith f kas kbs = do
250− tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
252− k' = theseTable fst fst (const fst) tkab
253− tab = bimap snd snd tkab
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').
263−-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
264−leftAlign :: EqTable k
265− => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
266−leftAlign = leftAlignWith (,)
269−-- | See 'zipWith' and 'leftAlign'.
272−-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
273−leftAlignWith :: EqTable k
274− => (a -> MaybeTable b -> c)
275− -> Tabulation k a -> Tabulation k b -> Tabulation k c
276−leftAlignWith f left right = liftA2 f left (optionalTabulation right)
280−-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
282−-- There are multiple correct ways of understanding what this does.
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.
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.
293−-- You can think of it as a natural join in SQL terms.
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.
299− => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
304−-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
308− => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
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.
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@.
324−similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
325−similarity kas kbs = do
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.
335−-- See 'Rel8.without'.
336−difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
337−difference kas kbs = do
340− fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
343−aggregateTabulation :: forall k aggregates exprs.
345− , Aggregates aggregates exprs
347− => Tabulation k aggregates -> Tabulation k exprs
348−aggregateTabulation = mapQuery $
349− fmap (first fromColumns) .
351− fmap (first (hgroupBy (eqTable @k) . toColumns))
354−-- | 'orderTabulation' orders the /values/ of a 'Tabulation' within each key.
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'.
359−orderTabulation :: OrdTable k => Order a -> Tabulation k a -> Tabulation k a
360−orderTabulation ordering = mapQuery $ orderBy ordering'
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.
369−distinctTabulation :: EqTable k => Tabulation k a -> Tabulation k a
370−distinctTabulation = mapQuery (distinctOn fst)
373−optionalTabulation :: EqTable k
374− => Tabulation k a -> Tabulation k (MaybeTable a)
375−optionalTabulation as = Tabulation $ \k -> do
376− ma <- optional $ lookup k as
380−manyTabulation :: (EqTable k, Table Expr a)
381− => Tabulation k a -> Tabulation k (ListTable a)
383− fmap (maybeTable mempty (\(ListTable a) -> ListTable a)) .
384− optionalTabulation .
385− aggregateTabulation .
386− fmap (listAgg . toColumns)
389−someTabulation :: (EqTable k, Table Expr a)
390− => Tabulation k a -> Tabulation k (NonEmptyTable a)
392− fmap (\(NonEmptyTable a) -> NonEmptyTable a) .
393− aggregateTabulation .
394− fmap (nonEmptyAgg . toColumns)
397−mapQuery :: (Query (k, a) -> Query (k, b)) -> Tabulation k a -> Tabulation k b
398−mapQuery f (Tabulation query) = Tabulation $ \k ->
399− first Just <$> f (first (fromMaybe k) <$> query k)
402−toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
403−toQuery (Tabulation as) = Tabulation $ \k ->
404− pure (Nothing, first (fromMaybe k) <$> as k)