Require Opaleye >= 0.7.3 (#81)

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

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/<owner>/<repo>/archive/<rev>.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/<owner>/<repo>/archive/<rev>.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/<owner>/<repo>/archive/<rev>.tar.gz"
     }
 }

nix/sources.nix

@@ -6,25 +6,33 @@ let
   # The fetchers. fetch_<type> fetches specs of type <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 = <nixpkgs> == ./.;
     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;

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

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'.

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

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.

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)

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.

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))
       ]