1{-# language DeriveFunctor #-}
2{-# language DerivingStrategies #-}
3{-# language FlexibleContexts #-}
4{-# language LambdaCase #-}
5{-# language TupleSections #-}
6{-# language UndecidableInstances #-}
38import Control.Applicative ( liftA2 )
39import Control.Monad ( join, liftM2 )
40import Data.Bifunctor ( bimap, first )
41import Data.Foldable ( traverse_ )
42import Data.Functor.Contravariant ( (>$<) )
43import Data.Maybe ( fromMaybe )
44import Prelude hiding ( filter, lookup, undefined, zip, zipWith )
47import Rel8.Aggregate ( Aggregate )
48import Rel8.Expr ( Expr )
49import Rel8.Expr.Bool ( not_, true )
50import Rel8.Order ( Order )
51import Rel8.Query ( Query )
52import Rel8.Query.Aggregate ( aggregate )
53import Rel8.Query.Exists ( withBy, withoutBy )
54import Rel8.Query.Filter ( filter, where_ )
55import Rel8.Query.Maybe ( optional )
56import Rel8.Query.Order ( orderBy )
57import Rel8.Query.These ( alignBy )
58import Rel8.Table ( Table )
59import Rel8.Table.Aggregate ( groupBy, headAgg, listAgg, nonEmptyAgg )
60import Rel8.Table.Alternative
62 , AlternativeTable, emptyTable
64import Rel8.Table.Eq ( EqTable, (==:) )
65import Rel8.Table.List ( ListTable )
66import Rel8.Table.Maybe ( MaybeTable, maybeTable )
67import Rel8.Table.NonEmpty ( NonEmptyTable )
68import Rel8.Table.These ( TheseTable, theseTable )
69import Rel8.Table.Undefined ( undefined )
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.
82-- \"Identity\" 'Tabulation's are created using 'tabulate'. 'Tabulation's can
83-- be composed with 'Query's with 'prebind' or 'postbind' to form new
85newtype Tabulation k a = Tabulation (Either k k -> Query (Maybe k, a))
86 deriving stock Functor
89instance EqTable k => Apply (Tabulation k) where
93instance EqTable k => Applicative (Tabulation k) where
94 pure = liftQuery . pure
98instance EqTable k => Bind (Tabulation k) where
102instance EqTable k => Monad (Tabulation k) where
103 Tabulation as >>= f = Tabulation $ \i -> do
106 Nothing -> case f a of
107 Tabulation bs -> bs i
108 Just k -> case f a of
110 (mk', b) <- bs (Right k)
112 Nothing -> pure (mk, b)
118instance EqTable k => AltTable (Tabulation k) where
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)
131 (<>) = alignWith (theseTable id id (<>))
134instance (EqTable k, Table Expr a, Semigroup a) => Monoid (Tabulation k a)
139-- | This "undoes" 'fromQuery'.
142-- 'runTabulation' . 'fromQuery' = id
143-- 'fromQuery' . 'runTabulation' = id
146-- Note however that it produces nonsense when passed a 'Tabulation' that was
147-- made with from 'liftQuery' or 'pure'. In such cases the returned 'Query'
148-- will always produce zero rows.
149runTabulation :: EqTable k => Tabulation k a -> Query (k, a)
150runTabulation (Tabulation f) = do
151 (mk, a) <- f (Left undefined)
154 -- Opaleye tries to be too clever optimising "WHERE FALSE" and generates
155 -- invalid SQL, so we use "WHERE NOT TRUE" instead
158 Just k -> pure (k, a)
161liftQuery :: Query a -> Tabulation k a
162liftQuery query = Tabulation $ const $ fmap (Nothing,) query
165-- | 'tabulate' creates an \"identity\" @'Tabulation' k a@ that allows @a@ be
166-- indexed by one or more of its columns @k@. Some examples:
168-- [Tabulation by primary key]:
170-- projectsById :: Project 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Project 'Expr')
171-- projectsById = 'tabulate' projectId
174-- Note: the nature of primary keys means that each key will be mapped to a
175-- singleton value in this case.
177-- [Tabulation by other unique key]:
179-- projectsByName :: Project 'Expr' -> 'Tabulation' ('Expr' Text) (Project 'Expr')
180-- projectsByName = 'tabulate' projectName
183-- [Tabulation by foreign key (tabulate a child table by parent key)]:
185-- revisionsByProjectId :: Revision 'Expr' -> 'Tabulation' ('Expr' ProjectId) (Revision 'Expr')
186-- revisionsByProjectId = 'tabulate' revisionProjectId
188tabulate :: (a -> k) -> a -> Tabulation k a
189tabulate key a = fromQuery $ pure (key a, a)
192-- | Like 'tabulate' but takes a monadic 'Query' function instead of a pure
193-- one. This means you can filter rows while calculating the key, which is
194-- useful in conjunction with 'Rel8.Extra.catNulls'.
195tabulateA :: (a -> Query k) -> a -> Tabulation k a
196tabulateA key a = fromQuery $ (,a) <$> key a
199-- | Analgous to 'Data.Map.Strict.fromList'.
200fromQuery :: Query (k, a) -> Tabulation k a
201fromQuery = Tabulation . const . fmap (first Just)
204indexed :: Tabulation k a -> Tabulation k (k, a)
205indexed (Tabulation query) = Tabulation $ \i ->
206 (\(mk, a) -> (mk, (fromMaybe (either id id i) mk, a))) <$> query i
209ifilter :: (k -> a -> Expr Bool) -> Tabulation k a -> Tabulation k a
210ifilter f tabulation = snd <$> do
211 filter (uncurry f) `postbind` indexed tabulation
214-- | Map a 'Query' over the input side of a 'Tabulation'.
215prebind :: (a -> Tabulation k b) -> Query a -> Tabulation k b
216prebind f as = Tabulation $ \k -> do
219 Tabulation query -> query k
223-- | Map a 'Query' over the output side of a 'Tabulation'.
224postbind :: (a -> Query b) -> Tabulation k a -> Tabulation k b
225postbind f (Tabulation as) = Tabulation $ \i -> do
234-- | Note that because 'Tabulation' is a @MultiMap@, the 'Query' returned by
235-- 'lookup' can and often does contain multiple results.
236lookup :: EqTable k => k -> Tabulation k a -> Query a
237lookup key (Tabulation query) = do
238 (mk, a) <- query (Right key)
239 traverse_ (where_ . (key ==:)) mk
244-- [@align@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:align).
246-- If 'zip' makes an @INNER JOIN@, then 'align' makes a @FULL OUTER JOIN@.
247align :: (EqTable k, Table Expr a, Table Expr b)
248 => Tabulation k a -> Tabulation k b -> Tabulation k (TheseTable a b)
253-- [@alignWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:alignWith).
255-- See 'zipWith' and 'align'.
256alignWith :: (EqTable k, Table Expr a, Table Expr b)
257 => (TheseTable a b -> c)
258 -> Tabulation k a -> Tabulation k b -> Tabulation k c
259alignWith f kas kbs = do
263 tkab <- alignBy (\(l, _) (m, _) -> l ==: m) as bs
265 k' = theseTable fst fst (const fst) tkab
266 tab = bimap snd snd tkab
270-- | If 'zip' makes an @INNER JOIN@, then 'leftAlign' makes a @LEFT JOIN@.
271-- This means it will return at least one row for every row in the left
272-- 'Tabulation', even if there is no corresponding row in the right (hence the
273-- 'Rel8.MaybeTable').
276-- [@rpadZip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZip).
277leftAlign :: EqTable k
278 => Tabulation k a -> Tabulation k b -> Tabulation k (a, MaybeTable b)
279leftAlign = leftAlignWith (,)
282-- | See 'zipWith' and 'leftAlign'.
285-- [@rpadZipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:rpadZipWith).
286leftAlignWith :: EqTable k
287 => (a -> MaybeTable b -> c)
288 -> Tabulation k a -> Tabulation k b -> Tabulation k c
289leftAlignWith f left right = liftA2 f left (optionalTabulation right)
293-- [@zip@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zip).
295-- There are multiple correct ways of understanding what this does.
297-- You can think of it as @'Data.Map.Strict.intersectionWith'
298-- ('Control.Applicative.liftA2' (,))@. That is, @intersect@ the two
299-- `Tabulation`s by matching their keys together (with 'Rel8.==:'), and combine
300-- their values (remembering that 'Tabulation' is a 'MultiMap' so that the
301-- values are keys) by getting their cartesian product.
303-- You can think of it as performing a cross product of the underlying 'Query's
304-- of the given 'Tabulation's and filtering the results for 'match'ing keys.
306-- You can think of it as a natural join in SQL terms.
308-- The size of the resulting 'Tabulation' will be \(\sum_{k} min(n_k, m_k) \)
309-- in terms of the number of keys, but \(\sum_{k} n_k \times m_k\) in terms of
310-- the number of values.
312 => Tabulation k a -> Tabulation k b -> Tabulation k (a, b)
317-- [@zipWith@](https://hackage.haskell.org/package/semialign/docs/Data-Semialign.html#v:zipWith).
321 => (a -> b -> c) -> Tabulation k a -> Tabulation k b -> Tabulation k c
325-- | 'similarity' returns all the entries in the left 'Tabulation' that have a
326-- corresponding entry in the right 'Tabulation'. This corresponds to a
327-- semijoin in relational algebra.
329-- This differs from @'zipWith' const x y@ when the right 'Tabulation' @y@
330-- contains an entry with multiple rows. For 'similarity', the entries in the
331-- resulting 'Tabulation' will contain the same number of rows as their
332-- respective entries in the left 'Tabulation' @x@. With `zipWith const x y`,
333-- each entry would contain the /product/ of the number of rows of their
334-- respective entries in @x@ and @y@.
337similarity :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
338similarity kas kbs = do
341 fromQuery $ as >>= withBy (\(k, _) (l, _) -> k ==: l) bs
344-- | 'difference' returns all the entries in the left 'Tabulation' that don't
345-- exist in the right 'Tabulation'. This corresponds to an antijoin in
346-- relational algebra.
348-- See 'Rel8.without'.
349difference :: EqTable k => Tabulation k a -> Tabulation k b -> Tabulation k a
350difference kas kbs = do
353 fromQuery $ as >>= withoutBy (\(k, _) (l, _) -> k ==: l) bs
356aggregateTabulation :: EqTable k
357 => Tabulation k (Aggregate a) -> Tabulation k a
358aggregateTabulation kas = do
360 fromQuery $ aggregate $ bitraverse1 groupBy id <$> as
363-- | 'orderTabulation' orders the /values/ of a 'Tabulation' (not the keys).
364-- In general this is meaningless, but if used together with 'manyTabulation'
365-- or 'someTabulation', the resulting lists will be ordered according to
366-- ordering given to 'orderTabulation'.
367orderTabulation :: Order a -> Tabulation k a -> Tabulation k a
368orderTabulation ordering (Tabulation as) =
369 Tabulation $ orderBy (snd >$< ordering) . as
372-- | Turns the given 'Tabulation' from a \"multimap\" into a \"map\". If there
373-- is more than one value at a particular key, only the first one is kept.
374-- \"First\" is in general undefined, but 'orderTabulation' can be used to
375-- make it deterministic.
376singularize :: (EqTable k, Table Expr a) => Tabulation k a -> Tabulation k a
377singularize = aggregateTabulation . fmap headAgg
380optionalTabulation :: EqTable k
381 => Tabulation k a -> Tabulation k (MaybeTable a)
382optionalTabulation as = Tabulation $ \case
384 Tabulation f -> fmap pure <$> f (Left k)
386 ma <- optional $ lookup k as
390manyTabulation :: (EqTable k, Table Expr a)
391 => Tabulation k a -> Tabulation k (ListTable a)
393 fmap (maybeTable mempty id) .
395 aggregateTabulation .
399someTabulation :: (EqTable k, Table Expr a)
400 => Tabulation k a -> Tabulation k (NonEmptyTable a)
401someTabulation = aggregateTabulation . fmap nonEmptyAgg
404toQuery :: Tabulation k a -> Tabulation k (Query (k, a))
405toQuery (Tabulation as) = Tabulation $ \k ->
406 pure (Nothing, first (fromMaybe (either id id k)) <$> as k)
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list