From bf193950ab47f9b367ad05daa37312962ddcb72c Mon Sep 17 00:00:00 2001 From: Ollie Charles Date: Mon, 28 Jun 2021 20:33:55 +0400 Subject: [PATCH] Require Opaleye >= 0.7.3 (#81) 0.7.3 has important changes to where lateral joins are introduced, and fixes #72. --- nix/sources.json | 18 +++++------ nix/sources.nix | 66 ++++++++++++++++++++++++++------------ 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 +++---- 9 files changed, 90 insertions(+), 80 deletions(-) diff --git a/nix/sources.json b/nix/sources.json index 8320b7e..b3a10cc 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "https://input-output-hk.github.io/haskell.nix", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "e7bb8ab2921a11a1d014c70a87898f73e086594d", - "sha256": "17c0xqzwnchcy71p8372cydcxc7qf0i8x12d0lf6p1g8yd4al6fa", + "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f", + "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87", "type": "tarball", - "url": "https://github.com/input-output-hk/haskell.nix/archive/e7bb8ab2921a11a1d014c70a87898f73e086594d.tar.gz", + "url": "https://github.com/input-output-hk/haskell.nix/archive/3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "niv": { @@ -17,10 +17,10 @@ "homepage": "https://github.com/nmattia/niv", "owner": "nmattia", "repo": "niv", - "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e", - "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n", + "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070", + "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx", "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz", + "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, "nixpkgs": { @@ -29,10 +29,10 @@ "homepage": null, "owner": "nixos", "repo": "nixpkgs", - "rev": "a6847cb5460b47241eb35d1a6588652411642066", - "sha256": "0wb5hwgffr4in66qng22sfvbascwnq078q81ziwwayvmnkn73rrm", + "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8", + "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c", "type": "tarball", - "url": "https://github.com/nixos/nixpkgs/archive/a6847cb5460b47241eb35d1a6588652411642066.tar.gz", + "url": "https://github.com/nixos/nixpkgs/archive/59b8d9cf24e9fcf10341a0923c9bdca088dca8c8.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/nix/sources.nix b/nix/sources.nix index b64b8f8..1938409 100644 --- a/nix/sources.nix +++ b/nix/sources.nix @@ -6,25 +6,33 @@ let # The fetchers. fetch_ fetches specs of type . # - fetch_file = pkgs: spec: - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; } - else - pkgs.fetchurl { inherit (spec) url sha256; }; + fetch_file = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; fetch_tarball = pkgs: name: spec: let - ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str); - # sanitize the name, though nix will still fail if name starts with period - name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src"; + name' = sanitizeName name + "-src"; in if spec.builtin or true then builtins_fetchTarball { name = name'; inherit (spec) url sha256; } else pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; - fetch_git = spec: - builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; + fetch_git = name: spec: + let + ref = + if spec ? ref then spec.ref else + if spec ? branch then "refs/heads/${spec.branch}" else + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + in + builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; fetch_local = spec: spec.path; @@ -40,11 +48,21 @@ let # Various helpers # + # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 + sanitizeName = name: + ( + concatMapStrings (s: if builtins.isList s then "-" else s) + ( + builtins.split "[^[:alnum:]+._?=-]+" + ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) + ) + ); + # The set of packages used when specs are fetched using non-builtins. - mkPkgs = sources: + mkPkgs = sources: system: let sourcesNixpkgs = - import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {}; + import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; hasThisAsNixpkgsPath = == ./.; in @@ -64,9 +82,9 @@ let if ! builtins.hasAttr "type" spec then abort "ERROR: niv spec ${name} does not have a 'type' attribute" - else if spec.type == "file" then fetch_file pkgs spec + else if spec.type == "file" then fetch_file pkgs name spec else if spec.type == "tarball" then fetch_tarball pkgs name spec - else if spec.type == "git" then fetch_git spec + else if spec.type == "git" then fetch_git name spec else if spec.type == "local" then fetch_local spec else if spec.type == "builtin-tarball" then fetch_builtin-tarball name else if spec.type == "builtin-url" then fetch_builtin-url name @@ -80,7 +98,10 @@ let saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; in - if ersatz == "" then drv else ersatz; + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; # Ports of functions for older nix versions @@ -98,25 +119,29 @@ let # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatMapStrings = f: list: concatStrings (map f list); concatStrings = builtins.concatStringsSep ""; + # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 + optionalAttrs = cond: as: if cond then as else {}; + # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, name, sha256 }@attrs: + builtins_fetchTarball = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchTarball; in if lessThan nixVersion "1.12" then - fetchTarball { inherit name url; } + fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) else fetchTarball attrs; # fetchurl version that is compatible between all the versions of Nix - builtins_fetchurl = { url, sha256 }@attrs: + builtins_fetchurl = { url, name ? null, sha256 }@attrs: let inherit (builtins) lessThan nixVersion fetchurl; in if lessThan nixVersion "1.12" then - fetchurl { inherit url; } + fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) else fetchurl attrs; @@ -135,7 +160,8 @@ let mkConfig = { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) - , pkgs ? mkPkgs sources + , system ? builtins.currentSystem + , pkgs ? mkPkgs sources system }: rec { # The sources, i.e. the attribute set of spec name to spec inherit sources; 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)) ]