README.md

@@ -74,9 +74,4 @@ getScoreByAge conn = do
 - [ ] Implement JSON decoding
 - [ ] Implement (anonymous) composite types
 - [ ] Catch [UnicodeException](https://hackage.haskell.org/package/text-2.1/docs/Data-Text-Encoding-Error.html#t:UnicodeException) when decoding text
-    - This might not be necessary if Postgres guarantees us that having a textual OID on a field means that the field is encoded correctly.
 - [ ] Implement array decoding
-- [ ] Better docs and structure for `FromRow` module
-- [ ] Lexer for PostgreSQL that replaces $name by $1, $2, etc.
-- [ ] Tutorial
-- [ ] Rationale

lib/Database/PostgreSQL/Opium.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -6,74 +7,47 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Database.PostgreSQL.Opium
-    -- * Queries
-    --
-    -- | TODO: Add @newtype Query = Query Text@ with @IsString@ instance to make constructing query strings at run time harder.
-  ( fetch
-  , fetch_
-  , execute
-  , execute_
-    -- * Classes to Implement
-  , FromRow (..)
-  , FromField (..)
-  , ToParamList (..)
-  , ToField (..)
-    -- * Utility Stuff
+  ( ColumnTable
   , Error (..)
   , ErrorPosition (..)
+  , FromField (..)
+  , FromRow (..)
   , RawField (..)
+  , fetch
+  , fetch_
+  , toListColumnTable
   )
   where
 
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
+import Data.ByteString (ByteString)
+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
+import Data.Vector (Vector)
 import Database.PostgreSQL.LibPQ
-  ( Connection
+  ( Column
+  , Connection
+  , Oid
   , Result
+  , Row
   )
+import GHC.Generics (C, D, Generic, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
+import GHC.TypeLits (KnownSymbol, symbolVal)
 
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Encoding
+import qualified Data.Vector as Vector
 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.ToField (ToField (..))
+import Database.PostgreSQL.Opium.FromField (FromField (..), fromField, RawField (..))
 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]
-
-fetch_ :: forall a. FromRow a => Connection -> Text -> IO (Either Error [a])
-fetch_ conn query = fetch conn query ()
-
-execute
-  :: forall a. ToParamList a
-  => Connection
-  -> Text
-  -> a
-  -> IO (Either Error ())
-execute conn query params = runExceptT $ do
-  _ <- execParams conn query params
-  pure ()
-
-execute_ :: Connection -> Text -> IO (Either Error ())
-execute_ conn query = execute conn query ()
-
 execParams
   :: ToParamList a
   => Connection
@@ -92,3 +66,126 @@ execParams conn query params = do
         Just "" -> pure result
         Nothing -> pure result
         Just message -> except $ Left $ ErrorInvalidResult status $ Encoding.decodeUtf8 message
+
+fetch
+  :: forall a b. (ToParamList a, FromRow b)
+  => Connection
+  -> Text
+  -> a
+  -> IO (Either Error [b])
+fetch conn query params = runExceptT $ do
+  result <- execParams conn query params
+  columnTable <- ExceptT $ getColumnTable @b Proxy result
+  nRows <- liftIO $ LibPQ.ntuples result
+  mapM (ExceptT . fromRow result columnTable) [0..nRows - 1]
+
+fetch_ :: forall a. FromRow a => Connection -> Text -> IO (Either Error [a])
+fetch_ conn query = fetch conn query ()
+
+newtype ColumnTable = ColumnTable (Vector (Column, Oid))
+  deriving (Eq, Show)
+
+newColumnTable :: [(Column, Oid)] -> ColumnTable
+newColumnTable = ColumnTable . Vector.fromList
+
+indexColumnTable :: ColumnTable -> Int -> (Column, Oid)
+indexColumnTable (ColumnTable v) i = v `Vector.unsafeIndex` i
+
+toListColumnTable :: ColumnTable -> [(Column, Oid)]
+toListColumnTable (ColumnTable v) = Vector.toList v
+
+class FromRow a where
+  getColumnTable :: Proxy a -> Result -> IO (Either Error ColumnTable)
+  default getColumnTable :: (Generic a, GetColumnTable' (Rep a)) => Proxy a -> Result -> IO (Either Error ColumnTable)
+  getColumnTable Proxy = runExceptT . fmap newColumnTable . getColumnTable' @(Rep a) Proxy
+
+  fromRow :: Result -> ColumnTable -> Row -> IO (Either Error a)
+  default fromRow :: (Generic a, FromRow' (Rep a)) => Result -> ColumnTable -> Row -> IO (Either Error a)
+  fromRow result columnTable row = do
+    iRef <- newIORef 0
+    runExceptT $ to <$> fromRow' (FromRowCtx result columnTable iRef) row
+
+class GetColumnTable' f where
+  getColumnTable' :: Proxy (f p) -> Result -> ExceptT Error IO [(Column, Oid)]
+
+instance GetColumnTable' f => GetColumnTable' (M1 D c f) where
+  getColumnTable' Proxy = getColumnTable' @f Proxy
+
+instance GetColumnTable' f => GetColumnTable' (M1 C c f) where
+  getColumnTable' Proxy = getColumnTable' @f Proxy
+
+instance (GetColumnTable' f, GetColumnTable' g) => GetColumnTable' (f :*: g) where
+  getColumnTable' Proxy result =
+    (++) <$> getColumnTable' @f Proxy result <*> getColumnTable' @g Proxy result
+
+checkColumn :: forall a. FromField a => Proxy a -> String -> Result -> ExceptT Error IO [(Column, Oid)]
+checkColumn Proxy nameStr result = do
+  column <- ExceptT $ maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name
+  oid <- liftIO $ LibPQ.ftype result column
+  if validOid @a Proxy oid then
+    pure [(column, oid)]
+  else
+    except $ Left $ ErrorInvalidOid nameText oid
+  where
+    nameText = Text.pack nameStr
+    name = Encoding.encodeUtf8 nameText
+
+instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
+  getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
+
+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
+
+data FromRowCtx = FromRowCtx Result ColumnTable (IORef Int)
+
+class FromRow' f where
+  fromRow' :: FromRowCtx -> Row -> ExceptT Error IO (f p)
+
+instance FromRow' f => FromRow' (M1 D c f) where
+  fromRow' ctx row = M1 <$> fromRow' ctx row
+
+instance FromRow' f => FromRow' (M1 C c f) where
+  fromRow' ctx row = M1 <$> fromRow' ctx row
+
+instance (FromRow' f, FromRow' g) => FromRow' (f :*: g) where
+  fromRow' ctx row = do
+    y <- fromRow' ctx row
+    z <- fromRow' ctx row
+    pure $ y :*: z
+
+decodeField
+  :: FromField t
+  => Text
+  -> (Row -> Maybe t -> Either Error t')
+  -> FromRowCtx
+  -> Row
+  -> ExceptT Error IO (M1 S m (Rec0 t') p)
+decodeField nameText g (FromRowCtx result columnTable iRef) row = do
+  i <- liftIO $ readIORef iRef
+  liftIO $ modifyIORef' iRef (+1)
+  let (column, oid) = columnTable `indexColumnTable` i
+  mbField <- liftIO $ LibPQ.getvalue result row column
+  mbValue <- except $ getValue oid mbField
+  value <- except $ g row mbValue
+  pure $ M1 $ K1 value
+  where
+    getValue :: FromField u => LibPQ.Oid -> Maybe ByteString -> Either Error (Maybe u)
+    getValue oid = maybe (Right Nothing) $ \field ->
+      mapLeft
+        (ErrorInvalidField (ErrorPosition row nameText) oid field)
+        (Just <$> fromField field)
+
+mapLeft :: (b -> c) -> Either b a -> Either c a
+mapLeft f (Left l) = Left $ f l
+mapLeft _ (Right r) = Right r
+
+instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
+  fromRow' = decodeField nameText $ \row ->
+    maybe (Left $ ErrorUnexpectedNull $ ErrorPosition row nameText) Right
+    where
+      nameText = Text.pack $ symbolVal @nameSym Proxy
+
+instance {-# OVERLAPPING #-} (KnownSymbol nameSym, FromField t) => FromRow' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 (Maybe t))) where
+  fromRow' = decodeField nameText $ const pure
+    where
+      nameText = Text.pack $ symbolVal @nameSym Proxy

lib/Database/PostgreSQL/Opium/FromRow.hs

@@ -1,162 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Database.PostgreSQL.Opium.FromRow
-  -- * FromRow
-  ( FromRow (..)
-  -- * Internal
-  , toListColumnTable
-  ) where
-
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (ExceptT (..), except, runExceptT)
-import Data.ByteString (ByteString)
-import Data.Bifunctor (first)
-import Data.Kind (Type)
-import Data.Proxy (Proxy (..))
-import Data.Text (Text)
-import Data.Vector (Vector)
-import Database.PostgreSQL.LibPQ
-  ( Column
-  , Oid
-  , Result
-  , Row
-  )
-import GHC.Generics (Generic, C, D, K1 (..), M1 (..), Meta (..), Rec0, Rep, S, to, (:*:) (..))
-import GHC.TypeLits (KnownNat, KnownSymbol, Nat, natVal, symbolVal, type (+))
-
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Encoding
-import qualified Data.Vector as Vector
-import qualified Database.PostgreSQL.LibPQ as LibPQ
-
-import Database.PostgreSQL.Opium.Error (Error (..), ErrorPosition (..))
-import Database.PostgreSQL.Opium.FromField (FromField (..), fromField)
-
-class FromRow a where
-  getColumnTable :: Proxy a -> Result -> IO (Either Error ColumnTable)
-  default getColumnTable :: (Generic a, GetColumnTable' (Rep a)) => Proxy a -> Result -> IO (Either Error ColumnTable)
-  getColumnTable Proxy = runExceptT . fmap newColumnTable . getColumnTable' @(Rep a) Proxy
-
-  fromRow :: Result -> ColumnTable -> Row -> IO (Either Error a)
-  default fromRow :: (Generic a, FromRow' 0 (Rep a)) => Result -> ColumnTable -> Row -> IO (Either Error a)
-  fromRow result columnTable row =
-    runExceptT $ to <$> fromRow' @0 FRProxy (FromRowCtx result columnTable) row
-
-newtype ColumnTable = ColumnTable (Vector (Column, Oid))
-  deriving (Eq, Show)
-
-newColumnTable :: [(Column, Oid)] -> ColumnTable
-newColumnTable = ColumnTable . Vector.fromList
-
-indexColumnTable :: ColumnTable -> Int -> (Column, Oid)
-indexColumnTable (ColumnTable v) i = v `Vector.unsafeIndex` i
-
-toListColumnTable :: ColumnTable -> [(Column, Oid)]
-toListColumnTable (ColumnTable v) = Vector.toList v
-
-class GetColumnTable' f where
-  getColumnTable' :: Proxy (f p) -> Result -> ExceptT Error IO [(Column, Oid)]
-
-instance GetColumnTable' f => GetColumnTable' (M1 D c f) where
-  getColumnTable' Proxy = getColumnTable' @f Proxy
-
-instance GetColumnTable' f => GetColumnTable' (M1 C c f) where
-  getColumnTable' Proxy = getColumnTable' @f Proxy
-
-instance (GetColumnTable' f, GetColumnTable' g) => GetColumnTable' (f :*: g) where
-  getColumnTable' Proxy result =
-    (++) <$> getColumnTable' @f Proxy result <*> getColumnTable' @g Proxy result
-
-instance {-# OVERLAPPABLE #-} (FromField t, KnownSymbol nameSym) => GetColumnTable' (M1 S ('MetaSel ('Just nameSym) nu ns dl) (Rec0 t)) where
-  getColumnTable' Proxy = checkColumn @t Proxy $ symbolVal @nameSym Proxy
-
-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
-
--- | State kept for a call to 'fromRow'.
-data FromRowCtx = FromRowCtx
-  Result -- ^ Obtained from 'LibPQ.execParams'.
-  ColumnTable -- ^ 'Vector' of expected columns indices and OIDs.
-
-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
-
-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
-
-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 {-# 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
-      memberIndex = fromIntegral $ natVal @n Proxy
-      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
-      nameText = Text.pack $ symbolVal @nameSym Proxy
-
-checkColumn :: forall a. FromField a => Proxy a -> String -> Result -> ExceptT Error IO [(Column, Oid)]
-checkColumn Proxy nameStr result = do
-  column <- ExceptT $ maybe (Left $ ErrorMissingColumn nameText) Right <$> LibPQ.fnumber result name
-  oid <- liftIO $ LibPQ.ftype result column
-  if validOid @a Proxy oid then
-    pure [(column, oid)]
-  else
-    except $ Left $ ErrorInvalidOid nameText oid
-  where
-    nameText = Text.pack nameStr
-    name = Encoding.encodeUtf8 nameText
-
-decodeField
-  :: FromField t
-  => Int
-  -> Text
-  -> (Row -> Maybe t -> Either Error t')
-  -> FromRowCtx
-  -> Row
-  -> ExceptT Error IO (M1 S m (Rec0 t') p)
-decodeField memberIndex nameText g (FromRowCtx result columnTable) row = do
-  let (column, oid) = columnTable `indexColumnTable` memberIndex
-  mbField <- liftIO $ LibPQ.getvalue result row column
-  mbValue <- except $ fromFieldIfPresent oid mbField
-  value <- except $ g row mbValue
-  pure $ M1 $ K1 value
-  where
-    fromFieldIfPresent :: FromField u => LibPQ.Oid -> Maybe ByteString -> Either Error (Maybe u)
-    fromFieldIfPresent oid = maybe (Right Nothing) $ \field ->
-      first
-        (ErrorInvalidField (ErrorPosition row nameText) oid field)
-        (Just <$> fromField field)
-

opium.cabal

@@ -62,14 +62,13 @@ library
     exposed-modules:
         Database.PostgreSQL.Opium,
         Database.PostgreSQL.Opium.FromField,
-        Database.PostgreSQL.Opium.FromRow,
         Database.PostgreSQL.Opium.ToField
 
     -- Modules included in this library but not exported.
     other-modules:
         Database.PostgreSQL.Opium.Error,
-        Database.PostgreSQL.Opium.Oid,
-        Database.PostgreSQL.Opium.ToParamList
+        Database.PostgreSQL.Opium.ToParamList,
+        Database.PostgreSQL.Opium.Oid
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:

test/Database/PostgreSQL/OpiumSpec.hs

@@ -7,7 +7,6 @@
 module Database.PostgreSQL.OpiumSpec (spec) where
 
 import Data.ByteString (ByteString)
-import Data.Either (isLeft)
 import Data.Functor.Identity (Identity (..))
 import Data.Proxy (Proxy (..))
 import Data.Text (Text)
@@ -17,7 +16,6 @@ import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy)
 
 import qualified Database.PostgreSQL.LibPQ as LibPQ
 import qualified Database.PostgreSQL.Opium as Opium
-import qualified Database.PostgreSQL.Opium.FromRow as Opium.FromRow
 
 data Person = Person
   { name :: Text
@@ -55,6 +53,10 @@ newtype Only a = Only
 
 instance Opium.FromField a => Opium.FromRow (Only a) where
 
+isLeft :: Either a b -> Bool
+isLeft (Left _) = True
+isLeft _ = False
+
 shouldHaveColumns
   :: Opium.FromRow a
   => Proxy a
@@ -65,7 +67,7 @@ shouldHaveColumns
 shouldHaveColumns proxy conn query expectedColumns = do
   Just result <- LibPQ.execParams conn query [] LibPQ.Binary
   columnTable <- Opium.getColumnTable proxy result
-  let actualColumns = fmap (map fst . Opium.FromRow.toListColumnTable) columnTable
+  let actualColumns = fmap (map fst . Opium.toListColumnTable) columnTable
   actualColumns `shouldBe` Right expectedColumns
 
 spec :: SpecWith Connection