Set system to aarch64-darwin

README.md

@@ -33,8 +33,8 @@ data User = User
 
 instance Opium.FromRow User where
 
-getUsers :: Connection -> IO (Either Opium.Error [Users])
-getUsers conn = Opium.fetch_ conn "SELECT * FROM user"
+getUsers :: Connection -> IO (Either Opium.Error [User])
+getUsers = Opium.fetch_ "SELECT * FROM user"
 ```
 
 The `Opium.FromRow` instance is implemented generically for all product types ("records"). It looks up the field name in the query result and decodes the column value using `Opium.FromField`.
@@ -51,7 +51,7 @@ instance Opium.FromRow ScoreByAge where
 getScoreByAge :: Connection -> IO ScoreByAge
 getScoreByAge conn = do
   let query = "SELECT regr_intercept(score, age) AS t, regr_slope(score, age) AS m FROM user"
-  Right [x] <- Opium.fetch_ conn query
+  Right (Identity x) <- Opium.fetch_ query conn
   pure x
 ```
 
@@ -83,3 +83,4 @@ getScoreByAge conn = do
     - [ ] `FromRow`
     - [ ] Custom `FromField` impls
 - [ ] Improve type errors when trying to `instance` a type that isn't a record (e.g. sum type)
+- [ ] Improve documentation for `fromRow` module

flake.lock

@@ -2,11 +2,11 @@
   "nodes": {
     "nixpkgs": {
       "locked": {
-        "lastModified": 1681753173,
-        "narHash": "sha256-MrGmzZWLUqh2VstoikKLFFIELXm/lsf/G9U9zR96VD4=",
+        "lastModified": 1719285171,
+        "narHash": "sha256-kOUKtKfYEh8h8goL/P6lKF4Jb0sXnEkFyEganzdTGvo=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "0a4206a51b386e5cda731e8ac78d76ad924c7125",
+        "rev": "cfb89a95f19bea461fc37228dc4d07b22fe617c2",
         "type": "github"
       },
       "original": {

flake.nix

@@ -3,33 +3,24 @@
 
   outputs = { self, nixpkgs }:
     let
-      pkgs = nixpkgs.legacyPackages.x86_64-linux;
+      system = "aarch64-darwin";
+      pkgs = nixpkgs.legacyPackages.${system};
+      opium = pkgs.haskellPackages.developPackage {
+        root = ./.;
+        modifier = drv:
+          pkgs.haskell.lib.addBuildTools drv [
+            pkgs.cabal-install
+            pkgs.haskellPackages.implicit-hie
+            pkgs.haskell-language-server
+          ];
+      };
     in {
-      apps.x86_64-linux.cabal = {
-        type = "app";
-        program = "${nixpkgs.legacyPackages.x86_64-linux.cabal-install}/bin/cabal";
+      packages.${system}.opium = pkgs.haskell.lib.overrideCabal opium {
+        # Currently the tests require a running Postgres instance.
+        # This is not automated yet, so don't export the tests.
+        doCheck = false;
       };
-      devShells.x86_64-linux.default = pkgs.mkShell {
-        packages = [
-          pkgs.cabal-install
-          pkgs.haskellPackages.implicit-hie
-          (pkgs.ghc.withPackages (hp: with hp; [
-            attoparsec
-            containers
-            bytestring
-            hspec
-            postgresql-libpq
-            text
-            time
-            transformers
-            vector
-          ]))
 
-          pkgs.haskell-language-server
-        ];
-        shellHook = ''
-          PS1="<opium> ''${PS1}"
-        '';
-      };
+      devShells.${system}.default = opium.env;
     };
 }

lib/Database/PostgreSQL/Opium.hs

@@ -1,15 +1,14 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Database.PostgreSQL.Opium
     -- * Queries
     --
+    -- Functions for performing queries. @fetch@ retrieves rows, @execute@ doesn't.
+    -- The 'Connection' parameter comes last to facilitate currying for implicitly passing in the connection, e.g. from some framework's connection pool.
+    --
     -- | TODO: Add @newtype Query = Query Text@ with @IsString@ instance to make constructing query strings at run time harder.
   ( fetch
   , fetch_
@@ -27,9 +26,10 @@ module Database.PostgreSQL.Opium
   )
   where
 
-import Control.Monad (void)
+import Control.Monad (unless, void)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
+import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT, throwE)
+import Data.Functor.Identity (Identity (..))
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
 import Database.PostgreSQL.LibPQ
@@ -42,36 +42,54 @@ import qualified Database.PostgreSQL.LibPQ as LibPQ
 
 import Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..))
 import Database.PostgreSQL.Opium.FromField (FromField (..), RawField (..))
-import Database.PostgreSQL.Opium.FromRow (FromRow (..))
+import Database.PostgreSQL.Opium.FromRow (FromRow (..), ColumnTable)
 import Database.PostgreSQL.Opium.ToField (ToField (..))
 import Database.PostgreSQL.Opium.ToParamList (ToParamList (..))
 
--- The order of the type parameters is important, because it is more common to use type applications for providing the row type.
-fetch
-  :: forall a b. (ToParamList b, FromRow a)
-  => Connection
-  -> Text
-  -> b
-  -> IO (Either Error [a])
-fetch conn query params = runExceptT $ do
-  result <- execParams conn query params
-  columnTable <- ExceptT $ getColumnTable @a Proxy result
-  nRows <- liftIO $ LibPQ.ntuples result
-  mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
+class RowContainer c where
+  extract :: FromRow a => Result -> LibPQ.Row -> ColumnTable -> ExceptT Error IO (c a)
 
-fetch_ :: forall a. FromRow a => Connection -> Text -> IO (Either Error [a])
-fetch_ conn query = fetch conn query ()
+instance RowContainer [] where
+  extract result nRows columnTable = do
+    mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
+
+instance RowContainer Maybe where
+  extract result nRows columnTable
+    | nRows == 0 = pure Nothing
+    | nRows == 1 = Just <$> ExceptT (fromRow result columnTable 0)
+    | otherwise = throwE ErrorMoreThanOneRow
+
+instance RowContainer Identity where
+  extract result nRows columnTable = do
+    unless (nRows == 1) $ throwE ErrorNotExactlyOneRow
+    Identity <$> ExceptT (fromRow result columnTable 0)
+
+-- The order of the type parameters is important, because it is more common to use type applications for providing the row type and row container type.
+fetch
+  :: forall a b c. (ToParamList c, FromRow a, RowContainer b)
+  => Text
+  -> c
+  -> Connection
+  -> IO (Either Error (b a))
+fetch query params conn = runExceptT $ do
+  result <- execParams conn query params
+  nRows <- liftIO $ LibPQ.ntuples result
+  columnTable <- ExceptT $ getColumnTable @a Proxy result
+  extract result nRows columnTable
+
+fetch_ :: forall a c. (FromRow a, RowContainer c) => Text -> Connection -> IO (Either Error (c a))
+fetch_ query = fetch query ()
 
 execute
   :: forall a. ToParamList a
-  => Connection
-  -> Text
+  => Text
   -> a
+  -> Connection
   -> IO (Either Error ())
-execute conn query params = runExceptT $ void $ execParams conn query params
+execute query params conn = runExceptT $ void $ execParams conn query params
 
-execute_ :: Connection -> Text -> IO (Either Error ())
-execute_ conn query = execute conn query ()
+execute_ :: Text -> Connection -> IO (Either Error ())
+execute_ query = execute query ()
 
 execParams
   :: ToParamList a

lib/Database/PostgreSQL/Opium/Error.hs

@@ -17,6 +17,8 @@ data Error
   | ErrorInvalidOid Text Oid
   | ErrorUnexpectedNull ErrorPosition
   | ErrorInvalidField ErrorPosition Oid ByteString String
+  | ErrorNotExactlyOneRow
+  | ErrorMoreThanOneRow
   deriving (Eq, Show)
 
 instance Exception Error where

lib/Database/PostgreSQL/Opium/FromRow.hs

@@ -14,6 +14,7 @@ module Database.PostgreSQL.Opium.FromRow
   -- * FromRow
   ( FromRow (..)
   -- * Internal
+  , ColumnTable
   , toListColumnTable
   ) where
 
@@ -52,12 +53,34 @@ class FromRow a where
   fromRow result columnTable row =
     runExceptT $ to <$> fromRow' @0 FRProxy (FromRowCtx result columnTable) row
 
+instance
+  ( Generic a
+  , GetColumnTable' (Rep a)
+  , FromRow' 0 (Rep a)
+  , Generic b
+  , GetColumnTable' (Rep b)
+  , FromRow' (NumberOfMembers (Rep a)) (Rep b)
+  ) => FromRow (a, b) where
+  getColumnTable Proxy result = runExceptT $ do
+    ctA <- newColumnTable <$> getColumnTable' @(Rep a) Proxy result
+    ctB <- newColumnTable <$> getColumnTable' @(Rep b) Proxy result
+    pure $ ctA `concatColumnTables` ctB
+
+  fromRow result ct row = runExceptT $ do
+    x <- to <$> fromRow' @0 FRProxy (FromRowCtx result ct) row
+    y <- to <$> fromRow' @(NumberOfMembers (Rep a)) FRProxy (FromRowCtx result ct) row
+    pure (x, y)
+
 newtype ColumnTable = ColumnTable (Vector (Column, Oid))
   deriving (Eq, Show)
 
 newColumnTable :: [(Column, Oid)] -> ColumnTable
 newColumnTable = ColumnTable . Vector.fromList
 
+concatColumnTables :: ColumnTable -> ColumnTable -> ColumnTable
+concatColumnTables (ColumnTable a) (ColumnTable b) =
+  ColumnTable $ a <> b
+
 indexColumnTable :: ColumnTable -> Int -> (Column, Oid)
 indexColumnTable (ColumnTable v) i = v `Vector.unsafeIndex` i
 
@@ -83,36 +106,41 @@ instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTab
 instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
   getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
 
+-- | Number of members in the generic representation of a record type (doesn't support sum types).
+type family NumberOfMembers f where
+  -- The data type itself has as many members as the type that it defines.
+  NumberOfMembers (M1 D _ f) = NumberOfMembers f
+  -- The constructor has as many members as the type that it contains.
+  NumberOfMembers (M1 C _ f) = NumberOfMembers f
+  -- A product type has as many members as its subtypes have together.
+  NumberOfMembers (f :*: g) = NumberOfMembers f + NumberOfMembers g
+  -- A selector has/is exactly one member.
+  NumberOfMembers (M1 S _ f) = 1
+
 -- | State kept for a call to 'fromRow'.
 data FromRowCtx = FromRowCtx
   Result -- ^ Obtained from 'LibPQ.execParams'.
   ColumnTable -- ^ 'Vector' of expected columns indices and OIDs.
 
+-- Specialized proxy type to be used instead of `Proxy (n, f)`
 data FRProxy (n :: Nat) (f :: Type -> Type) = FRProxy
 
 class FromRow' (n :: Nat) (f :: Type -> Type) where
-  type Members f :: Nat
-
   fromRow' :: FRProxy n f -> FromRowCtx -> Row -> ExceptT Error IO (f p)
 
 instance FromRow' n f => FromRow' n (M1 D c f) where
-  type Members (M1 D c f) = Members f
-
-  fromRow' FRProxy ctx row = M1 <$> fromRow' @n FRProxy ctx row
+  fromRow' FRProxy ctx row =
+    M1 <$> fromRow' @n FRProxy ctx row
 
 instance FromRow' n f => FromRow' n (M1 C c f) where
-  type Members (M1 C c f) = Members f
+  fromRow' FRProxy ctx row =
+    M1 <$> fromRow' @n FRProxy ctx row
 
-  fromRow' FRProxy ctx row = M1 <$> fromRow' @n FRProxy ctx row
-
-instance (FromRow' n f, FromRow' (n + Members f) g) => FromRow' n (f :*: g) where
-  type Members (f :*: g) = Members f + Members g
-
-  fromRow' FRProxy ctx row = (:*:) <$> fromRow' @n FRProxy ctx row <*> fromRow' @(n + Members f) FRProxy ctx row
+instance (FromRow' n f, FromRow' (n + NumberOfMembers f) g) => FromRow' n (f :*: g) where
+  fromRow' FRProxy ctx row =
+    (:*:) <$> fromRow' @n FRProxy ctx row <*> fromRow' @(n + NumberOfMembers f) FRProxy ctx row
 
 instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol nameSym, FromField t) => FromRow' n (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
-  type Members (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) = 1
-
   fromRow' FRProxy = decodeField memberIndex nameText $ \row ->
     maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
     where
@@ -120,8 +148,6 @@ instance {-# OVERLAPPABLE #-} (KnownNat n, KnownSymbol nameSym, FromField t) =>
       nameText = Text.pack $ symbolVal @nameSym Proxy
 
 instance {-# OVERLAPPING #-} (KnownNat n, KnownSymbol nameSym, FromField t) => FromRow' n (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
-  type Members (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) = 1
-
   fromRow' FRProxy = decodeField memberIndex nameText $ const pure
     where
       memberIndex = fromIntegral $ natVal @n Proxy
@@ -159,4 +185,3 @@ decodeField memberIndex nameText g (FromRowCtx result columnTable) row = do
       first
         (ErrorInvalidField (ErrorPosition row nameText) oid field)
         (Just <$> fromField field)
-

opium.cabal

@@ -52,7 +52,7 @@ build-type:         Simple
 -- extra-source-files:
 
 common warnings
-    ghc-options: -Wall
+    ghc-options: -Wall -Wextra
 
 library
     -- Import common warning flags.

test/Database/PostgreSQL/Opium/FromFieldSpec.hs

@@ -115,7 +115,7 @@ instance FromRow ARawField where
 
 shouldFetch :: (Eq a, FromRow a, Show a) => Connection -> Text -> [a] -> IO ()
 shouldFetch conn query expectedRows = do
-  actualRows <- Opium.fetch_ conn query
+  actualRows <- Opium.fetch_ query conn
   actualRows `shouldBe` Right expectedRows
 
 (/\) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
@@ -213,15 +213,15 @@ spec = do
       shouldFetch conn "SELECT 4.2::real AS float" [AFloat 4.2]
 
     it "Decodes NaN::real" $ \conn -> do
-      Right [AFloat value] <- Opium.fetch_ conn "SELECT 'NaN'::real AS float"
+      Right [AFloat value] <- Opium.fetch_ "SELECT 'NaN'::real AS float" conn
       value `shouldSatisfy` isNaN
 
     it "Decodes Infinity::real" $ \conn -> do
-      Right [AFloat value] <- Opium.fetch_ conn "SELECT 'Infinity'::real AS float"
+      Right [AFloat value] <- Opium.fetch_ "SELECT 'Infinity'::real AS float" conn
       value `shouldSatisfy` (isInfinite /\ (> 0))
 
     it "Decodes -Infinity::real" $ \conn -> do
-      Right [AFloat value] <- Opium.fetch_ conn "SELECT '-Infinity'::real AS float"
+      Right [AFloat value] <- Opium.fetch_ "SELECT '-Infinity'::real AS float" conn
       value `shouldSatisfy` (isInfinite /\ (< 0))
 
   describe "FromField Double" $ do
@@ -229,22 +229,22 @@ spec = do
       shouldFetch conn "SELECT 4.2::double precision AS double" [ADouble 4.2]
 
     it "Decodes NaN::double precision" $ \conn -> do
-      Right [ADouble value] <- Opium.fetch_ conn "SELECT 'NaN'::double precision AS double"
+      Right [ADouble value] <- Opium.fetch_ "SELECT 'NaN'::double precision AS double" conn
       value `shouldSatisfy` isNaN
 
     it "Decodes Infinity::double precision" $ \conn -> do
-      Right [ADouble value] <- Opium.fetch_ conn "SELECT 'Infinity'::double precision AS double"
+      Right [ADouble value] <- Opium.fetch_ "SELECT 'Infinity'::double precision AS double" conn
       value `shouldSatisfy` (isInfinite /\ (> 0))
 
     it "Decodes -Infinity::double precision" $ \conn -> do
-      Right [ADouble value] <- Opium.fetch_ conn "SELECT '-Infinity'::double precision AS double"
+      Right [ADouble value] <- Opium.fetch_ "SELECT '-Infinity'::double precision AS double" conn
       value `shouldSatisfy` (isInfinite /\ (< 0))
 
     it "Decodes {inf,-inf}::double precision" $ \conn -> do
-      Right [ADouble value0] <- Opium.fetch_ conn "SELECT 'inf'::double precision AS double"
+      Right [ADouble value0] <- Opium.fetch_ "SELECT 'inf'::double precision AS double" conn
       value0 `shouldSatisfy` (isInfinite /\ (> 0))
 
-      Right [ADouble value1] <- Opium.fetch_ conn "SELECT '-inf'::double precision AS double"
+      Right [ADouble value1] <- Opium.fetch_ "SELECT '-inf'::double precision AS double" conn
       value1 `shouldSatisfy` (isInfinite /\ (< 0))
 
   describe "FromField Bool" $ do

test/Database/PostgreSQL/OpiumSpec.hs

@@ -122,32 +122,63 @@ spec = do
       row <- Opium.fromRow result columnTable 0
       row `shouldBe` Right (ManyFields "abc" 42 1.0 "test" True)
 
+    it "Decodes multiple records into a tuple" $ \conn -> do
+      Just result <- LibPQ.execParams conn "SELECT 'albus' AS name, 123 AS age, 42 AS only" [] LibPQ.Binary
+      Right columnTable <- Opium.getColumnTable @(Person, Only Int) Proxy result
+
+      row <- Opium.fromRow @(Person, Only Int) result columnTable 0
+      row `shouldBe` Right (Person "albus" 123, Only 42)
+
   describe "fetch" $ do
     it "Passes numbered parameters and retrieves a list of rows" $ \conn -> do
-      rows <- Opium.fetch conn "SELECT ($1 + $2) AS only" (17 :: Int, 25 :: Int)
+      rows <- Opium.fetch "SELECT ($1 + $2) AS only" (17 :: Int, 25 :: Int) conn
       rows `shouldBe` Right [Only (42 :: Int)]
 
     it "Uses Identity to pass single parameters" $ \conn -> do
-      rows <- Opium.fetch conn "SELECT count(*) AS only FROM person WHERE name = $1" $ Identity ("paul" :: Text)
+      rows <- Opium.fetch "SELECT count(*) AS only FROM person WHERE name = $1" (Identity ("paul" :: Text)) conn
       rows `shouldBe` Right [Only (1 :: Int)]
 
   describe "fetch_" $ do
     it "Retrieves a list of rows" $ \conn -> do
-      rows <- Opium.fetch_ conn "SELECT * FROM person"
+      rows <- Opium.fetch_ "SELECT * FROM person" conn
       rows `shouldBe` Right [Person "paul" 25, Person "albus" 103]
 
     it "Fails for invalid queries" $ \conn -> do
-      rows <- Opium.fetch_ @Person conn "MRTLBRNFT"
+      rows <- Opium.fetch_ @Person @[] "MRTLBRNFT" conn
       rows `shouldSatisfy` isLeft
 
     it "Fails for unexpected NULLs" $ \conn -> do
-      rows <- Opium.fetch_ @Person conn "SELECT NULL AS name, 0 AS age"
+      rows <- Opium.fetch_ @Person @[] "SELECT NULL AS name, 0 AS age" conn
       rows `shouldBe` Left (Opium.ErrorUnexpectedNull (Opium.ErrorPosition 0 "name"))
 
     it "Fails for the wrong column type" $ \conn -> do
-      rows <- Opium.fetch_ @Person conn "SELECT 'quby' AS name, 'indeterminate' AS age"
+      rows <- Opium.fetch_ @Person @[] "SELECT 'quby' AS name, 'indeterminate' AS age" conn
       rows `shouldBe` Left (Opium.ErrorInvalidOid "age" $ LibPQ.Oid 25)
 
     it "Works for the readme regression example" $ \conn -> do
-      rows <- Opium.fetch_ @ScoreByAge conn "SELECT regr_intercept(score, age) AS t, regr_slope(score, age) AS m FROM person"
+      rows <- Opium.fetch_ @ScoreByAge @[] "SELECT regr_intercept(score, age) AS t, regr_slope(score, age) AS m FROM person" conn
       rows `shouldSatisfy` \case { (Right [ScoreByAge _ _]) -> True; _ -> False }
+
+    it "Accepts exactly one row when Identity is the row container type" $ \conn -> do
+      row <- Opium.fetch_ "SELECT 42 AS only" conn
+      row `shouldBe` Right (Identity (Only (42 :: Int)))
+
+    it "Does not accept zero rows when Identity is the row container type" $ \conn -> do
+      row <- Opium.fetch_ @(Only Int) @Identity "SELECT 42 AS only WHERE false" conn
+      row `shouldSatisfy` isLeft
+
+    it "Does not accept two rows when Identity is the row container type" $ \conn -> do
+      row <- Opium.fetch_ @(Only Int) @Identity "SELECT 17 AS only UNION ALL SELECT 25 AS only" conn
+      row `shouldSatisfy` isLeft
+
+    it "Accepts zero rows when Maybe is the row container type" $ \conn -> do
+      row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 17 AS only WHERE false" conn
+      row `shouldBe` Right Nothing
+
+    it "Accepts one row when Maybe is the row container type" $ \conn -> do
+      row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 42 AS only" conn
+      row `shouldBe` Right (Just (Only 42))
+
+    it "Does not accept two rows when Maybe is the row container type" $ \conn -> do
+      row <- Opium.fetch_ @(Only Int) @Maybe "SELECT 17 AS only UNION ALL SELECT 25 AS only" conn
+      row `shouldSatisfy` isLeft