mirror of
https://github.com/circuithub/rel8.git
synced 2024-09-11 16:05:41 +03:00
alignBy doesn't actually need any Table constraints
We can use the same technique we use in `optional` to get rid of them.
This commit is contained in:
parent
e83f356e99
commit
294543e530
@ -13,17 +13,15 @@ import qualified Opaleye.Internal.PackMap as Opaleye
|
||||
import qualified Opaleye.Internal.PrimQuery as Opaleye
|
||||
import qualified Opaleye.Internal.QueryArr as Opaleye
|
||||
import qualified Opaleye.Internal.Tag as Opaleye
|
||||
import qualified Opaleye.Internal.Unpackspec as Opaleye
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr.Bool ( true )
|
||||
import Rel8.Expr.Eq ( (==.) )
|
||||
import Rel8.Expr.Opaleye ( toPrimExpr )
|
||||
import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
|
||||
import Rel8.Query ( Query )
|
||||
import Rel8.Query.Filter ( where_ )
|
||||
import Rel8.Query.Opaleye ( mapOpaleye )
|
||||
import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
|
||||
import Rel8.Table.Opaleye ( unpackspec )
|
||||
import Rel8.Table.Tag ( Tag(..), fromExpr )
|
||||
|
||||
|
||||
@ -33,17 +31,18 @@ import Rel8.Table.Tag ( Tag(..), fromExpr )
|
||||
-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
|
||||
-- JOIN@s.
|
||||
optional :: Query a -> Query (MaybeTable a)
|
||||
optional = mapOpaleye $ Opaleye.QueryArr . go
|
||||
where
|
||||
go query (i, left, tag) =
|
||||
(MaybeTable (fromExpr t') a, join, Opaleye.next tag')
|
||||
where
|
||||
(MaybeTable Tag {expr = t} a, right, tag') =
|
||||
Opaleye.runSimpleQueryArr (pure <$> query) (i, tag)
|
||||
(t', bindings) = Opaleye.run $
|
||||
Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "maybe" tag') t
|
||||
join = Opaleye.Join Opaleye.LeftJoin condition [] bindings left right
|
||||
condition = toPrimExpr true
|
||||
optional = mapOpaleye $ \query -> Opaleye.QueryArr $ \i -> case i of
|
||||
(_, left, tag) -> (ma', join, tag'')
|
||||
where
|
||||
(ma, right, tag') = Opaleye.runSimpleQueryArr (pure <$> query) ((), tag)
|
||||
MaybeTable Tag {expr = just} a = ma
|
||||
(just', bindings) = Opaleye.run $ do
|
||||
traversePrimExpr (Opaleye.extractAttr "isJust" tag') just
|
||||
tag'' = Opaleye.next tag'
|
||||
join = Opaleye.Join Opaleye.LeftJoin on [] bindings left right
|
||||
where
|
||||
on = toPrimExpr true
|
||||
ma' = MaybeTable (fromExpr just') a
|
||||
|
||||
|
||||
-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
|
||||
|
@ -15,26 +15,26 @@ where
|
||||
import Prelude
|
||||
|
||||
-- opaleye
|
||||
import qualified Opaleye.Internal.Join as Opaleye
|
||||
import qualified Opaleye.Internal.PackMap as Opaleye
|
||||
import qualified Opaleye.Internal.PrimQuery as Opaleye
|
||||
import qualified Opaleye.Internal.QueryArr as Opaleye
|
||||
import qualified Opaleye.Internal.Tag as Opaleye
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr ( Expr )
|
||||
import Rel8.Expr.Bool ( boolExpr, not_ )
|
||||
import Rel8.Expr.Eq ( (==.) )
|
||||
import Rel8.Expr.Opaleye ( toColumn, toPrimExpr )
|
||||
import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
|
||||
import Rel8.Expr.Serialize ( litExpr )
|
||||
import Rel8.Query ( Query )
|
||||
import Rel8.Query.Filter ( where_ )
|
||||
import Rel8.Query.Maybe ( optional )
|
||||
import Rel8.Query.Opaleye ( zipOpaleyeWith )
|
||||
import Rel8.Table ( Table )
|
||||
import Rel8.Table.Either ( EitherTable( EitherTable ) )
|
||||
import Rel8.Table.Maybe ( MaybeTable( MaybeTable ), isJustTable )
|
||||
import Rel8.Table.Opaleye ( unpackspec )
|
||||
import Rel8.Table.Tag ( Tag(..) )
|
||||
import Rel8.Table.Tag ( Tag(..), fromExpr )
|
||||
import Rel8.Table.These
|
||||
( TheseTable( TheseTable )
|
||||
( TheseTable( TheseTable, here, there )
|
||||
, hasHereTable, hasThereTable
|
||||
, isThisTable, isThatTable, isThoseTable
|
||||
)
|
||||
@ -42,17 +42,28 @@ import Rel8.Type.Tag ( EitherTag( IsLeft, IsRight ) )
|
||||
|
||||
|
||||
-- | Corresponds to a @FULL OUTER JOIN@ between two queries.
|
||||
alignBy :: (Table Expr a, Table Expr b)
|
||||
alignBy :: ()
|
||||
=> (a -> b -> Expr Bool)
|
||||
-> Query a -> Query b -> Query (TheseTable a b)
|
||||
alignBy condition as bs =
|
||||
uncurry TheseTable <$> zipOpaleyeWith fullOuterJoin as bs
|
||||
where
|
||||
fullOuterJoin a b =
|
||||
Opaleye.joinExplicit unpackspec unpackspec pure pure full a b on
|
||||
where
|
||||
full = Opaleye.FullJoin
|
||||
on = toColumn . toPrimExpr . uncurry condition
|
||||
alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
|
||||
(_, input, tag) -> (tab, join', tag''')
|
||||
where
|
||||
(ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
|
||||
(mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
|
||||
MaybeTable Tag {expr = hasHere} a = ma
|
||||
MaybeTable Tag {expr = hasThere} b = mb
|
||||
(hasHere', lbindings) = Opaleye.run $ do
|
||||
traversePrimExpr (Opaleye.extractAttr "hasHere" tag'') hasHere
|
||||
(hasThere', rbindings) = Opaleye.run $ do
|
||||
traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
|
||||
tag''' = Opaleye.next tag''
|
||||
join = Opaleye.Join Opaleye.FullJoin on lbindings rbindings left' right'
|
||||
where
|
||||
on = toPrimExpr $ condition a b
|
||||
ma' = MaybeTable (fromExpr hasHere') a
|
||||
mb' = MaybeTable (fromExpr hasThere') b
|
||||
tab = TheseTable {here = ma', there = mb'}
|
||||
join' = Opaleye.times input join
|
||||
|
||||
|
||||
-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.
|
||||
|
Loading…
Reference in New Issue
Block a user