From 8957a75bc65f6a5343ac780df6e2196ee72081c7 Mon Sep 17 00:00:00 2001 From: Shane O'Brien Date: Fri, 25 Jun 2021 10:49:54 +0100 Subject: [PATCH] Port to Opaleye lateral branch --- rel8.cabal | 2 +- src/Rel8/Query.hs | 22 ++++++++-------------- src/Rel8/Query/Evaluate.hs | 4 ++-- src/Rel8/Query/Maybe.hs | 24 ++++++------------------ src/Rel8/Query/Opaleye.hs | 14 +++++++------- src/Rel8/Query/These.hs | 8 +++++--- tests/Main.hs | 12 ++++++------ 7 files changed, 35 insertions(+), 51 deletions(-) diff --git a/rel8.cabal b/rel8.cabal index c9d58cd..8916d96 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -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 diff --git a/src/Rel8/Query.hs b/src/Rel8/Query.hs index 984dbf5..52b42e4 100644 --- a/src/Rel8/Query.hs +++ b/src/Rel8/Query.hs @@ -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'. diff --git a/src/Rel8/Query/Evaluate.hs b/src/Rel8/Query/Evaluate.hs index 1df26fa..0bde6b0 100644 --- a/src/Rel8/Query/Evaluate.hs +++ b/src/Rel8/Query/Evaluate.hs @@ -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 diff --git a/src/Rel8/Query/Maybe.hs b/src/Rel8/Query/Maybe.hs index 15fe5dd..102038e 100644 --- a/src/Rel8/Query/Maybe.hs +++ b/src/Rel8/Query/Maybe.hs @@ -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. diff --git a/src/Rel8/Query/Opaleye.hs b/src/Rel8/Query/Opaleye.hs index e86c89e..114accc 100644 --- a/src/Rel8/Query/Opaleye.hs +++ b/src/Rel8/Query/Opaleye.hs @@ -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) diff --git a/src/Rel8/Query/These.hs b/src/Rel8/Query/These.hs index 62b1178..4c240ea 100644 --- a/src/Rel8/Query/These.hs +++ b/src/Rel8/Query/These.hs @@ -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. diff --git a/tests/Main.hs b/tests/Main.hs index a4f5e57..f644156 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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)) ]