mirror of
https://github.com/circuithub/rel8.git
synced 2024-08-17 20:00:23 +03:00
Port to Opaleye lateral branch
This commit is contained in:
parent
ac2d382e5e
commit
8957a75bc6
@ -25,7 +25,7 @@ library
|
||||
, case-insensitive
|
||||
, contravariant
|
||||
, hasql ^>= 1.4.5.1
|
||||
, opaleye ^>= 0.7.2.0
|
||||
, opaleye ^>= 0.7.3.0
|
||||
, profunctors
|
||||
, scientific
|
||||
, semialign
|
||||
|
@ -169,14 +169,14 @@ instance Bind Query where
|
||||
|
||||
|
||||
instance Monad Query where
|
||||
Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, query, tag) ->
|
||||
Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->
|
||||
let
|
||||
Opaleye.QueryArr qa = q dummies
|
||||
((m, a), query', tag') = qa ((), query, tag)
|
||||
((m, a), query, tag') = qa ((), tag)
|
||||
Query q' = f a
|
||||
(dummies', query'', tag'') =
|
||||
(dummies', query', tag'') =
|
||||
( dummy : dummies
|
||||
, Opaleye.Rebind True bindings query'
|
||||
, \lateral -> Opaleye.Rebind True bindings . query lateral
|
||||
, Opaleye.next tag'
|
||||
)
|
||||
where
|
||||
@ -185,19 +185,13 @@ instance Monad Query where
|
||||
random = Opaleye.FunExpr "random" []
|
||||
name = Opaleye.extractAttr "dummy" tag'
|
||||
Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'
|
||||
-- NOTE: query''' and needsDummies are corecursive; only laziness saves
|
||||
-- us here.
|
||||
--
|
||||
-- This refactoring, if adopted, would allow us to do this without
|
||||
-- relying on laziness:
|
||||
-- https://github.com/tomjaguarpaw/haskell-opaleye/commit/8a23f5028ab7396290984d63a8316949909fdbb4
|
||||
((m'@(Any needsDummies), b), query'''', tag''') = qa' ((), query''', tag'')
|
||||
((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')
|
||||
query'''
|
||||
| needsDummies = query''
|
||||
| otherwise = query'
|
||||
| needsDummies = \lateral -> query'' lateral . query' lateral
|
||||
| otherwise = \lateral -> query'' lateral . query lateral
|
||||
m'' = m <> m'
|
||||
in
|
||||
((m'', b), query'''', tag''')
|
||||
((m'', b), query''', tag''')
|
||||
|
||||
|
||||
-- | '<|>:' = 'unionAll'.
|
||||
|
@ -55,13 +55,13 @@ laterally a = Query $ \bindings -> pure $ (Any True,) $
|
||||
-- variable in the SQL. The @a@ returned consists only of these
|
||||
-- variables. It's essentially a @let@ binding for Postgres expressions.
|
||||
rebind :: Table Expr a => a -> Query a
|
||||
rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, query, tag) ->
|
||||
rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->
|
||||
let
|
||||
tag' = Opaleye.next tag
|
||||
(a', bindings) = Opaleye.run $
|
||||
Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
|
||||
in
|
||||
((mempty, a'), Opaleye.Rebind True bindings query, tag')
|
||||
((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')
|
||||
|
||||
|
||||
foldl1' :: (a -> a -> a) -> NonEmpty a -> a
|
||||
|
@ -9,15 +9,11 @@ where
|
||||
import Prelude
|
||||
|
||||
-- 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
|
||||
import qualified Opaleye.Internal.MaybeFields as Opaleye
|
||||
|
||||
-- rel8
|
||||
import Rel8.Expr.Bool ( true )
|
||||
import Rel8.Expr.Eq ( (==.) )
|
||||
import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
|
||||
import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
|
||||
import Rel8.Query ( Query )
|
||||
import Rel8.Query.Filter ( where_ )
|
||||
import Rel8.Query.Opaleye ( mapOpaleye )
|
||||
@ -31,18 +27,10 @@ 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 $ \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
|
||||
optional =
|
||||
mapOpaleye $
|
||||
Opaleye.optionalInternal $
|
||||
MaybeTable . fromExpr . fromPrimExpr . fromColumn
|
||||
|
||||
|
||||
-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
|
||||
|
@ -40,23 +40,23 @@ zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
|
||||
mapping :: ()
|
||||
=> (Opaleye.Select a -> Opaleye.Select b)
|
||||
-> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
|
||||
mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, query, tag) ->
|
||||
mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->
|
||||
let
|
||||
((m, _), _, _) = qa ((), query, tag)
|
||||
((m, _), _, _) = qa ((), tag)
|
||||
Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)
|
||||
in
|
||||
qa' ((), query, tag)
|
||||
qa' ((), tag)
|
||||
|
||||
|
||||
zipping :: Semigroup m
|
||||
=> (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
|
||||
-> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
|
||||
zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =
|
||||
Opaleye.QueryArr $ \(_, query, tag) ->
|
||||
Opaleye.QueryArr $ \(_, tag) ->
|
||||
let
|
||||
((m, _), _, _) = qa ((), query, tag)
|
||||
((m', _), _, _) = qa' ((), query, tag)
|
||||
((m, _), _, _) = qa ((), tag)
|
||||
((m', _), _, _) = qa' ((), tag)
|
||||
m'' = m <> m'
|
||||
Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')
|
||||
in
|
||||
qa'' ((), query, tag)
|
||||
qa'' ((), tag)
|
||||
|
@ -46,7 +46,7 @@ alignBy :: ()
|
||||
=> (a -> b -> Expr Bool)
|
||||
-> Query a -> Query b -> Query (TheseTable a b)
|
||||
alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
|
||||
(_, input, tag) -> (tab, join', tag''')
|
||||
(_, tag) -> (tab, join', tag''')
|
||||
where
|
||||
(ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
|
||||
(mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
|
||||
@ -57,13 +57,15 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas
|
||||
(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'
|
||||
join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
|
||||
where
|
||||
on = toPrimExpr $ condition a b
|
||||
left'' = (lateral, Opaleye.Rebind True lbindings left')
|
||||
right'' = (lateral, Opaleye.Rebind True rbindings right')
|
||||
ma' = MaybeTable (fromExpr hasHere') a
|
||||
mb' = MaybeTable (fromExpr hasThere') b
|
||||
tab = TheseTable {here = ma', there = mb'}
|
||||
join' = Opaleye.times input join
|
||||
join' lateral input = Opaleye.times lateral input (join lateral)
|
||||
|
||||
|
||||
-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.
|
||||
|
@ -759,13 +759,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
|
||||
|
||||
normalize selected' ===
|
||||
[ (('a', 'd'), (0, 0))
|
||||
, (('b', 'd'), (1, 1))
|
||||
, (('c', 'd'), (2, 2))
|
||||
, (('a', 'e'), (3, 3))
|
||||
, (('a', 'e'), (1, 1))
|
||||
, (('a', 'f'), (2, 2))
|
||||
, (('b', 'd'), (3, 3))
|
||||
, (('b', 'e'), (4, 4))
|
||||
, (('c', 'e'), (5, 5))
|
||||
, (('a', 'f'), (6, 6))
|
||||
, (('b', 'f'), (7, 7))
|
||||
, (('b', 'f'), (5, 5))
|
||||
, (('c', 'd'), (6, 6))
|
||||
, (('c', 'e'), (7, 7))
|
||||
, (('c', 'f'), (8, 8))
|
||||
]
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user