on master help sign in
Require Opaleye >= 0.7.3 (#81)

0.7.3 has important changes to where lateral joins are introduced, and fixes #72.

commitbf193950ab47f9b367ad05daa37312962ddcb72c authorOllie Charles <oliver.charles@circuithub.com> dateMon 28 Jun 2021, 20:33 (5 years ago) parentac2d382
9 files changed+90−80
nix/sources.json+9−9 nix/sources.nix+46−20 rel8.cabal+1−1 src/Rel8/Query.hs+8−14 src/Rel8/Query/Evaluate.hs+2−2 src/Rel8/Query/Maybe.hs+6−18 src/Rel8/Query/Opaleye.hs+7−7 src/Rel8/Query/These.hs+5−3 tests/Main.hs+6−6
nix/sources.json+9−9
@@ -5,10 +5,10 @@
55 "homepage": "https://input-output-hk.github.io/haskell.nix",
66 "owner": "input-output-hk",
77 "repo": "haskell.nix",
8− "rev": "e7bb8ab2921a11a1d014c70a87898f73e086594d",
9− "sha256": "17c0xqzwnchcy71p8372cydcxc7qf0i8x12d0lf6p1g8yd4al6fa",
8+ "rev": "3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f",
9+ "sha256": "0s69nasqhkv8n0qmdv075k83p3z584ja9vkzdnp2291mymghvx87",
1010 "type": "tarball",
11− "url": "https://github.com/input-output-hk/haskell.nix/archive/e7bb8ab2921a11a1d014c70a87898f73e086594d.tar.gz",
11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/3856d2d24dca0ecc71fcfc314253a2a2d07a3c4f.tar.gz",
1212 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
1313 },
1414 "niv": {
@@ -17,10 +17,10 @@
1717 "homepage": "https://github.com/nmattia/niv",
1818 "owner": "nmattia",
1919 "repo": "niv",
20− "rev": "af958e8057f345ee1aca714c1247ef3ba1c15f5e",
21− "sha256": "1qjavxabbrsh73yck5dcq8jggvh3r2jkbr6b5nlz5d9yrqm9255n",
20+ "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",
21+ "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",
2222 "type": "tarball",
23− "url": "https://github.com/nmattia/niv/archive/af958e8057f345ee1aca714c1247ef3ba1c15f5e.tar.gz",
23+ "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz",
2424 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
2525 },
2626 "nixpkgs": {
@@ -29,10 +29,10 @@
2929 "homepage": null,
3030 "owner": "nixos",
3131 "repo": "nixpkgs",
32− "rev": "a6847cb5460b47241eb35d1a6588652411642066",
33− "sha256": "0wb5hwgffr4in66qng22sfvbascwnq078q81ziwwayvmnkn73rrm",
32+ "rev": "59b8d9cf24e9fcf10341a0923c9bdca088dca8c8",
33+ "sha256": "08f38v4b2kcxnbapdwrb54bglka92cxj9qlnqlk5px206jyq9v4c",
3434 "type": "tarball",
35− "url": "https://github.com/nixos/nixpkgs/archive/a6847cb5460b47241eb35d1a6588652411642066.tar.gz",
35+ "url": "https://github.com/nixos/nixpkgs/archive/59b8d9cf24e9fcf10341a0923c9bdca088dca8c8.tar.gz",
3636 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
3737 }
3838}
nix/sources.nix+46−20
@@ -6,25 +6,33 @@ let
66 # The fetchers. fetch_<type> fetches specs of type <type>.
77 #
88
9− fetch_file = pkgs: spec:
10− if spec.builtin or true then
11− builtins_fetchurl { inherit (spec) url sha256; }
12− else
13− pkgs.fetchurl { inherit (spec) url sha256; };
9+ fetch_file = pkgs: name: spec:
10+ let
11+ name' = sanitizeName name + "-src";
12+ in
13+ if spec.builtin or true then
14+ builtins_fetchurl { inherit (spec) url sha256; name = name'; }
15+ else
16+ pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
1417
1518 fetch_tarball = pkgs: name: spec:
1619 let
17− ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str);
18− # sanitize the name, though nix will still fail if name starts with period
19− name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src";
20+ name' = sanitizeName name + "-src";
2021 in
2122 if spec.builtin or true then
2223 builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
2324 else
2425 pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
2526
26− fetch_git = spec:
27− builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; };
27+ fetch_git = name: spec:
28+ let
29+ ref =
30+ if spec ? ref then spec.ref else
31+ if spec ? branch then "refs/heads/${spec.branch}" else
32+ if spec ? tag then "refs/tags/${spec.tag}" else
33+ abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
34+ in
35+ builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; };
2836
2937 fetch_local = spec: spec.path;
3038
@@ -40,11 +48,21 @@ let
4048 # Various helpers
4149 #
4250
51+ # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
52+ sanitizeName = name:
53+ (
54+ concatMapStrings (s: if builtins.isList s then "-" else s)
55+ (
56+ builtins.split "[^[:alnum:]+._?=-]+"
57+ ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
58+ )
59+ );
60+
4361 # The set of packages used when specs are fetched using non-builtins.
44− mkPkgs = sources:
62+ mkPkgs = sources: system:
4563 let
4664 sourcesNixpkgs =
47− import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {};
65+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
4866 hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
4967 hasThisAsNixpkgsPath = <nixpkgs> == ./.;
5068 in
@@ -64,9 +82,9 @@ let
6482
6583 if ! builtins.hasAttr "type" spec then
6684 abort "ERROR: niv spec ${name} does not have a 'type' attribute"
67− else if spec.type == "file" then fetch_file pkgs spec
85+ else if spec.type == "file" then fetch_file pkgs name spec
6886 else if spec.type == "tarball" then fetch_tarball pkgs name spec
69− else if spec.type == "git" then fetch_git spec
87+ else if spec.type == "git" then fetch_git name spec
7088 else if spec.type == "local" then fetch_local spec
7189 else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
7290 else if spec.type == "builtin-url" then fetch_builtin-url name
@@ -80,7 +98,10 @@ let
8098 saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
8199 ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
82100 in
83− if ersatz == "" then drv else ersatz;
101+ if ersatz == "" then drv else
102+ # this turns the string into an actual Nix path (for both absolute and
103+ # relative paths)
104+ if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
84105
85106 # Ports of functions for older nix versions
86107
@@ -98,25 +119,29 @@ let
98119
99120 # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
100121 stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
122+ concatMapStrings = f: list: concatStrings (map f list);
101123 concatStrings = builtins.concatStringsSep "";
102124
125+ # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
126+ optionalAttrs = cond: as: if cond then as else {};
127+
103128 # fetchTarball version that is compatible between all the versions of Nix
104− builtins_fetchTarball = { url, name, sha256 }@attrs:
129+ builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
105130 let
106131 inherit (builtins) lessThan nixVersion fetchTarball;
107132 in
108133 if lessThan nixVersion "1.12" then
109− fetchTarball { inherit name url; }
134+ fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
110135 else
111136 fetchTarball attrs;
112137
113138 # fetchurl version that is compatible between all the versions of Nix
114− builtins_fetchurl = { url, sha256 }@attrs:
139+ builtins_fetchurl = { url, name ? null, sha256 }@attrs:
115140 let
116141 inherit (builtins) lessThan nixVersion fetchurl;
117142 in
118143 if lessThan nixVersion "1.12" then
119− fetchurl { inherit url; }
144+ fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
120145 else
121146 fetchurl attrs;
122147
@@ -135,7 +160,8 @@ let
135160 mkConfig =
136161 { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
137162 , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
138− , pkgs ? mkPkgs sources
163+ , system ? builtins.currentSystem
164+ , pkgs ? mkPkgs sources system
139165 }: rec {
140166 # The sources, i.e. the attribute set of spec name to spec
141167 inherit sources;
rel8.cabal+1−1
@@ -25,7 +25,7 @@ library
2525 , case-insensitive
2626 , contravariant
2727 , hasql ^>= 1.4.5.1
28− , opaleye ^>= 0.7.2.0
28+ , opaleye ^>= 0.7.3.0
2929 , profunctors
3030 , scientific
3131 , semialign
src/Rel8/Query.hs+8−14
@@ -169,14 +169,14 @@ instance Bind Query where
169169
170170
171171instance Monad Query where
172− Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, query, tag) ->
172+ Query q >>= f = Query $ \dummies -> Opaleye.QueryArr $ \(_, tag) ->
173173 let
174174 Opaleye.QueryArr qa = q dummies
175− ((m, a), query', tag') = qa ((), query, tag)
175+ ((m, a), query, tag') = qa ((), tag)
176176 Query q' = f a
177− (dummies', query'', tag'') =
177+ (dummies', query', tag'') =
178178 ( dummy : dummies
179− , Opaleye.Rebind True bindings query'
179+ , \lateral -> Opaleye.Rebind True bindings . query lateral
180180 , Opaleye.next tag'
181181 )
182182 where
@@ -185,19 +185,13 @@ instance Monad Query where
185185 random = Opaleye.FunExpr "random" []
186186 name = Opaleye.extractAttr "dummy" tag'
187187 Opaleye.QueryArr qa' = Opaleye.lateral $ \_ -> q' dummies'
188− -- NOTE: query''' and needsDummies are corecursive; only laziness saves
189− -- us here.
190− --
191− -- This refactoring, if adopted, would allow us to do this without
192− -- relying on laziness:
193− -- https://github.com/tomjaguarpaw/haskell-opaleye/commit/8a23f5028ab7396290984d63a8316949909fdbb4
194− ((m'@(Any needsDummies), b), query'''', tag''') = qa' ((), query''', tag'')
188+ ((m'@(Any needsDummies), b), query'', tag''') = qa' ((), tag'')
195189 query'''
196− | needsDummies = query''
197− | otherwise = query'
190+ | needsDummies = \lateral -> query'' lateral . query' lateral
191+ | otherwise = \lateral -> query'' lateral . query lateral
198192 m'' = m <> m'
199193 in
200− ((m'', b), query'''', tag''')
194+ ((m'', b), query''', tag''')
201195
202196
203197-- | '<|>:' = 'unionAll'.
src/Rel8/Query/Evaluate.hs+2−2
@@ -55,13 +55,13 @@ laterally a = Query $ \bindings -> pure $ (Any True,) $
5555-- variable in the SQL. The @a@ returned consists only of these
5656-- variables. It's essentially a @let@ binding for Postgres expressions.
5757rebind :: Table Expr a => a -> Query a
58−rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, query, tag) ->
58+rebind a = Query $ \_ -> Opaleye.QueryArr $ \(_, tag) ->
5959 let
6060 tag' = Opaleye.next tag
6161 (a', bindings) = Opaleye.run $
6262 Opaleye.runUnpackspec unpackspec (Opaleye.extractAttr "eval" tag') a
6363 in
64− ((mempty, a'), Opaleye.Rebind True bindings query, tag')
64+ ((mempty, a'), \_ -> Opaleye.Rebind True bindings, tag')
6565
6666
6767foldl1' :: (a -> a -> a) -> NonEmpty a -> a
src/Rel8/Query/Maybe.hs+6−18
@@ -9,15 +9,11 @@ where
99import Prelude
1010
1111-- opaleye
12−import qualified Opaleye.Internal.PackMap as Opaleye
13−import qualified Opaleye.Internal.PrimQuery as Opaleye
14−import qualified Opaleye.Internal.QueryArr as Opaleye
15−import qualified Opaleye.Internal.Tag as Opaleye
12+import qualified Opaleye.Internal.MaybeFields as Opaleye
1613
1714-- rel8
18−import Rel8.Expr.Bool ( true )
1915import Rel8.Expr.Eq ( (==.) )
20−import Rel8.Expr.Opaleye ( toPrimExpr, traversePrimExpr )
16+import Rel8.Expr.Opaleye ( fromColumn, fromPrimExpr )
2117import Rel8.Query ( Query )
2218import Rel8.Query.Filter ( where_ )
2319import Rel8.Query.Opaleye ( mapOpaleye )
@@ -31,18 +27,10 @@ import Rel8.Table.Tag ( Tag(..), fromExpr )
3127-- To speak in more concrete terms, 'optional' is most useful to write @LEFT
3228-- JOIN@s.
3329optional :: Query a -> Query (MaybeTable a)
34−optional = mapOpaleye $ \query -> Opaleye.QueryArr $ \i -> case i of
35− (_, left, tag) -> (ma', join, tag'')
36− where
37− (ma, right, tag') = Opaleye.runSimpleQueryArr (pure <$> query) ((), tag)
38− MaybeTable Tag {expr = just} a = ma
39− (just', bindings) = Opaleye.run $ do
40− traversePrimExpr (Opaleye.extractAttr "isJust" tag') just
41− tag'' = Opaleye.next tag'
42− join = Opaleye.Join Opaleye.LeftJoin on [] bindings left right
43− where
44− on = toPrimExpr true
45− ma' = MaybeTable (fromExpr just') a
30+optional =
31+ mapOpaleye $
32+ Opaleye.optionalInternal $
33+ MaybeTable . fromExpr . fromPrimExpr . fromColumn
4634
4735
4836-- | Filter out 'MaybeTable's, returning only the tables that are not-null.
src/Rel8/Query/Opaleye.hs+7−7
@@ -40,23 +40,23 @@ zipOpaleyeWith f (Query a) (Query b) = Query $ liftA2 (zipping f) a b
4040mapping :: ()
4141 => (Opaleye.Select a -> Opaleye.Select b)
4242 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b)
43−mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, query, tag) ->
43+mapping f q@(Opaleye.QueryArr qa) = Opaleye.QueryArr $ \(_, tag) ->
4444 let
45− ((m, _), _, _) = qa ((), query, tag)
45+ ((m, _), _, _) = qa ((), tag)
4646 Opaleye.QueryArr qa' = (m,) <$> f (snd <$> q)
4747 in
48− qa' ((), query, tag)
48+ qa' ((), tag)
4949
5050
5151zipping :: Semigroup m
5252 => (Opaleye.Select a -> Opaleye.Select b -> Opaleye.Select c)
5353 -> Opaleye.Select (m, a) -> Opaleye.Select (m, b) -> Opaleye.Select (m, c)
5454zipping f q@(Opaleye.QueryArr qa) q'@(Opaleye.QueryArr qa') =
55− Opaleye.QueryArr $ \(_, query, tag) ->
55+ Opaleye.QueryArr $ \(_, tag) ->
5656 let
57− ((m, _), _, _) = qa ((), query, tag)
58− ((m', _), _, _) = qa' ((), query, tag)
57+ ((m, _), _, _) = qa ((), tag)
58+ ((m', _), _, _) = qa' ((), tag)
5959 m'' = m <> m'
6060 Opaleye.QueryArr qa'' = (m'',) <$> f (snd <$> q) (snd <$> q')
6161 in
62− qa'' ((), query, tag)
62+ qa'' ((), tag)
src/Rel8/Query/These.hs+5−3
@@ -46,7 +46,7 @@ alignBy :: ()
4646 => (a -> b -> Expr Bool)
4747 -> Query a -> Query b -> Query (TheseTable a b)
4848alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> case i of
49− (_, input, tag) -> (tab, join', tag''')
49+ (_, tag) -> (tab, join', tag''')
5050 where
5151 (ma, left', tag') = Opaleye.runSimpleQueryArr (pure <$> left) ((), tag)
5252 (mb, right', tag'') = Opaleye.runSimpleQueryArr (pure <$> right) ((), tag')
@@ -57,13 +57,15 @@ alignBy condition = zipOpaleyeWith $ \left right -> Opaleye.QueryArr $ \i -> cas
5757 (hasThere', rbindings) = Opaleye.run $ do
5858 traversePrimExpr (Opaleye.extractAttr "hasThere" tag'') hasThere
5959 tag''' = Opaleye.next tag''
60− join = Opaleye.Join Opaleye.FullJoin on lbindings rbindings left' right'
60+ join lateral = Opaleye.Join Opaleye.FullJoin on left'' right''
6161 where
6262 on = toPrimExpr $ condition a b
63+ left'' = (lateral, Opaleye.Rebind True lbindings left')
64+ right'' = (lateral, Opaleye.Rebind True rbindings right')
6365 ma' = MaybeTable (fromExpr hasHere') a
6466 mb' = MaybeTable (fromExpr hasThere') b
6567 tab = TheseTable {here = ma', there = mb'}
66− join' = Opaleye.times input join
68+ join' lateral input = Opaleye.times lateral input (join lateral)
6769
6870
6971-- | Filter 'TheseTable's, keeping only 'thisTable's and 'thoseTable's.
tests/Main.hs+6−6
@@ -759,13 +759,13 @@ testEvaluate = databasePropertyTest "evaluate has the evaluation order we expect
759759
760760 normalize selected' ===
761761 [ (('a', 'd'), (0, 0))
762− , (('b', 'd'), (1, 1))
763− , (('c', 'd'), (2, 2))
764− , (('a', 'e'), (3, 3))
762+ , (('a', 'e'), (1, 1))
763+ , (('a', 'f'), (2, 2))
764+ , (('b', 'd'), (3, 3))
765765 , (('b', 'e'), (4, 4))
766− , (('c', 'e'), (5, 5))
767− , (('a', 'f'), (6, 6))
768− , (('b', 'f'), (7, 7))
766+ , (('b', 'f'), (5, 5))
767+ , (('c', 'd'), (6, 6))
768+ , (('c', 'e'), (7, 7))
769769 , (('c', 'f'), (8, 8))
770770 ]
771771