packages feed

valiant-fused-effects (empty) → 0.1.0.0

raw patch · 7 files changed

+474/−0 lines, 7 filesdep +basedep +bytestringdep +fused-effects

Dependencies added: base, bytestring, fused-effects, hspec, pg-wire, text, valiant, valiant-fused-effects

Files

+ CHANGELOG.md view
@@ -0,0 +1,15 @@+# Changelog++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++## [0.1.0.0] - 2026-04-25++Initial release.+[fused-effects](https://hackage.haskell.org/package/fused-effects)+adapter for [`valiant`](https://hackage.haskell.org/package/valiant).+Provides a `Valiant` effect, a `ValiantPoolC` carrier (built on+`ReaderC Pool`), and `Has (Reader Pool) sig m`-constrained smart+constructors for query, command, and transaction operations.++[0.1.0.0]: https://github.com/joshburgess/valiant/releases/tag/v0.1.0.0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2026 Josh Burgess++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from this+   software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,41 @@+# valiant-fused-effects++[fused-effects](https://hackage.haskell.org/package/fused-effects)+adapter for [`valiant`](https://hackage.haskell.org/package/valiant).++Provides a `Valiant` effect, a `ValiantPoolC` carrier (built on+`ReaderC Pool`), and `Has (Reader Pool) sig m`-constrained smart+constructors.++## Quick start++```haskell+import Control.Carrier.Lift (runM)+import Valiant (newPool, defaultPoolConfig, poolConnString)+import Valiant.FusedEffects++myApp :: (Has (Reader Pool) sig m, MonadIO m) => m [User]+myApp = do+  users <- fetchAllF listUsers ()+  pure users++main :: IO ()+main = do+  pool <- newPool defaultPoolConfig { poolConnString = "postgres://..." }+  users <- runM . runValiantPool pool $ myApp+  print users+```++## What you get++- Effect: `data Valiant`+- Carrier: `type ValiantPoolC m = ReaderC Pool m` with+  `runValiantPool :: Pool -> ValiantPoolC m a -> m a`+- Query operations: `fetchOneF`, `fetchAllF`, `fetchScalarF`,+  `fetchOneOrThrowF`, `fetchExistsF`+- Command operations: `executeF`, `executeReturningF`, `executeBatchF`+- Transactions: `withTransactionF`+- Raw access: `withConnectionF`++See the [valiant tutorial](https://github.com/joshburgess/valiant/blob/main/docs/TUTORIAL.md)+for `Statement` definitions and the `valiant prepare` workflow.
+ src/Valiant/FusedEffects.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE RankNTypes #-}++-- | Fused-effects adapter for valiant.+--+-- Provides an @Valiant@ effect with a pool-based carrier via 'ReaderC'.+--+-- @+-- import Control.Carrier.Lift (runM)+-- import Valiant.FusedEffects+--+-- myApp :: Has Valiant sig m => m [User]+-- myApp = do+--   users <- fetchAllF listUsers ()+--   pure users+--+-- main :: IO ()+-- main = do+--   pool <- newPool defaultPoolConfig { poolConnString = "..." }+--   result <- runM . runValiantPool pool $ myApp+--   print result+-- @+module Valiant.FusedEffects+  ( -- * Effect+    Valiant (..)++    -- * Carrier+  , ValiantPoolC+  , runValiantPool++    -- * Query operations+  , fetchOneF+  , fetchAllF+  , fetchScalarF+  , fetchOneOrThrowF+  , fetchExistsF++    -- * Command operations+  , executeF+  , executeReturningF+  , executeBatchF++    -- * Transaction operations+  , withTransactionF++    -- * Raw access+  , withConnectionF+  ) where++import Control.Algebra+import Control.Carrier.Reader (ReaderC, runReader)+import Control.Effect.Reader (Reader, ask)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Int (Int64)+import Data.Kind (Type)+import Valiant (Connection, Pool, Statement, Transaction)+import Valiant qualified+import PgWire.Pool (withResource)++------------------------------------------------------------------------+-- Effect+------------------------------------------------------------------------++-- | The Valiant database effect for fused-effects.+data Valiant (m :: Type -> Type) k where+  FetchOneF :: Statement p r -> p -> Valiant m (Maybe r)+  FetchAllF :: Statement p r -> p -> Valiant m [r]+  FetchScalarF :: Statement p r -> p -> Valiant m r+  FetchOneOrThrowF :: Statement p r -> p -> Valiant m r+  FetchExistsF :: Statement p r -> p -> Valiant m Bool+  ExecuteF :: Statement p () -> p -> Valiant m Int64+  ExecuteReturningF :: Statement p r -> p -> Valiant m (Int64, [r])+  ExecuteBatchF :: Statement p () -> [p] -> Valiant m Int64+  WithTransactionF :: (Transaction -> IO a) -> Valiant m a+  WithConnectionF :: (Connection -> IO a) -> Valiant m a++------------------------------------------------------------------------+-- Carrier (via ReaderC Pool)+------------------------------------------------------------------------++-- | Pool-based carrier. Uses 'ReaderC Pool' internally.+type ValiantPoolC m = ReaderC Pool m++-- | Run the Valiant effect with a connection pool.+runValiantPool :: Pool -> ValiantPoolC m a -> m a+runValiantPool = runReader++------------------------------------------------------------------------+-- Smart constructors (interpret directly via reader + IO)+------------------------------------------------------------------------++-- | Fetch zero or one row.+fetchOneF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p r -> p -> m (Maybe r)+fetchOneF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.fetchOne conn stmt params++-- | Fetch all rows.+fetchAllF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p r -> p -> m [r]+fetchAllF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.fetchAll conn stmt params++-- | Fetch exactly one scalar value.+fetchScalarF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p r -> p -> m r+fetchScalarF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.fetchScalar conn stmt params++-- | Fetch one row, throwing if none returned.+fetchOneOrThrowF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p r -> p -> m r+fetchOneOrThrowF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.fetchOneOrThrow conn stmt params++-- | Check if a query returns any rows.+fetchExistsF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p r -> p -> m Bool+fetchExistsF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.fetchExists conn stmt params++-- | Execute a command. Returns rows affected.+executeF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p () -> p -> m Int64+executeF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.execute conn stmt params++-- | Execute with RETURNING.+executeReturningF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p r -> p -> m (Int64, [r])+executeReturningF stmt params = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.executeReturning conn stmt params++-- | Execute a batch of commands (pipelined).+executeBatchF :: (Has (Reader Pool) sig m, MonadIO m) => Statement p () -> [p] -> m Int64+executeBatchF stmt paramsList = do+  pool <- ask+  liftIO $ withResource pool $ \conn -> Valiant.executeBatch conn stmt paramsList++-- | Run an action in a transaction.+withTransactionF :: (Has (Reader Pool) sig m, MonadIO m) => (Transaction -> IO a) -> m a+withTransactionF action = do+  pool <- ask+  liftIO $ Valiant.withTransaction pool action++-- | Run an action with a raw connection.+withConnectionF :: (Has (Reader Pool) sig m, MonadIO m) => (Connection -> IO a) -> m a+withConnectionF action = do+  pool <- ask+  liftIO $ withResource pool action
+ test/Main.hs view
@@ -0,0 +1,77 @@+module Main where++import Control.Carrier.Lift (runM)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Int (Int32)+import Data.Text (Text)+import Valiant (defaultPoolConfig, newPool, closePool)+import Valiant qualified+import Valiant.FusedEffects (fetchAllF, fetchOneF, executeF, runValiantPool)+import PgWire.Pool.Config (PoolConfig (..))+import System.Environment (lookupEnv)+import Test.Hspec+import TestSupport++main :: IO ()+main = hspec $ do+  describe "Valiant.FusedEffects" $ do+    it "fetchAllF returns all rows" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        result <- runM . runValiantPool pool $ fetchAllF stmtListAll ()+        closePool pool+        length result `shouldBe` 5++    it "fetchOneF returns Just for existing row" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        result <- runM . runValiantPool pool $ fetchOneF stmtSelectOne 1+        closePool pool+        case result of+          Just (_, name, _) -> name `shouldBe` "Alice"+          Nothing -> expectationFailure "Expected a row"++    it "fetchOneF returns Nothing for missing row" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        pool <- mkPool+        result <- runM . runValiantPool pool $ fetchOneF stmtSelectOne (-1)+        closePool pool+        result `shouldBe` (Nothing :: Maybe (Int32, Text, Maybe Text))++    it "executeF returns rows affected" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        let stmtDel = Valiant.mkStatement "DELETE FROM users_fused_effects WHERE id = $1" [23] [] "<test>" :: Valiant.Statement Int32 ()+        n <- runM . runValiantPool pool $ executeF stmtDel (1 :: Int32)+        closePool pool+        n `shouldBe` 1++    it "composes multiple operations" $ do+      withTestConnection $ \conn -> withSchema conn $ do+        insertTestUsers conn+        pool <- mkPool+        (users, mUser) <- runM . runValiantPool pool $ do+          us <- fetchAllF stmtListAll ()+          mu <- fetchOneF stmtSelectOne 1+          pure (us, mu)+        closePool pool+        length users `shouldBe` 5+        case mUser of+          Just (_, name, _) -> name `shouldBe` "Alice"+          Nothing -> expectationFailure "Expected a row"++mkPool :: IO Valiant.Pool+mkPool = do+  url <- requireDatabaseUrl'+  newPool defaultPoolConfig { poolConnString = url, poolSize = 2, poolAcquireTimeout = 5 }++requireDatabaseUrl' :: IO ByteString+requireDatabaseUrl' = do+  mUrl <- lookupEnv "DATABASE_URL"+  case mUrl of+    Just url -> pure (BS8.pack url)+    Nothing -> error "DATABASE_URL is not set."
+ test/TestSupport.hs view
@@ -0,0 +1,63 @@+module TestSupport+  ( withTestConnection+  , withSchema+  , insertTestUsers+  , stmtListAll+  , stmtSelectOne+  ) where++import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS8+import Data.Int (Int32)+import Data.Text (Text)+import Valiant+import System.Environment (lookupEnv)++requireDatabaseUrl :: IO ByteString+requireDatabaseUrl = do+  mUrl <- lookupEnv "DATABASE_URL"+  case mUrl of+    Just url -> pure (BS8.pack url)+    Nothing -> error "DATABASE_URL is not set."++withTestConnection :: (Connection -> IO a) -> IO a+withTestConnection action = do+  url <- requireDatabaseUrl+  conn <- connectString url+  result <- action conn+  close conn+  pure result++withSchema :: Connection -> IO a -> IO a+withSchema conn action = do+  _ <- simpleQuery conn "DROP TABLE IF EXISTS users_fused_effects CASCADE"+  _ <- simpleQuery conn+    "CREATE TABLE users_fused_effects (\+    \  id SERIAL PRIMARY KEY,\+    \  name TEXT NOT NULL,\+    \  email TEXT\+    \)"+  result <- action+  _ <- simpleQuery conn "DROP TABLE IF EXISTS users_fused_effects CASCADE"+  pure result++insertTestUsers :: Connection -> IO ()+insertTestUsers conn = do+  _ <- simpleQuery conn+    "INSERT INTO users_fused_effects (name, email) VALUES \+    \('Alice', 'alice@example.com'),\+    \('Bob', 'bob@example.com'),\+    \('Carol', NULL),\+    \('Dave', 'dave@example.com'),\+    \('Eve', 'eve@example.com')"+  pure ()++stmtListAll :: Statement () (Int32, Text)+stmtListAll = mkStatement+  "SELECT id, name FROM users_fused_effects ORDER BY id"+  [] ["id", "name"] "<test>"++stmtSelectOne :: Statement Int32 (Int32, Text, Maybe Text)+stmtSelectOne = mkStatement+  "SELECT id, name, email FROM users_fused_effects WHERE id = $1"+  [23] ["id", "name", "email"] "<test>"
+ valiant-fused-effects.cabal view
@@ -0,0 +1,102 @@+cabal-version:   3.0+name:            valiant-fused-effects+version:         0.1.0.0+synopsis:        Fused-effects adapter for valiant+description:+  Provides an @Valiant@ effect and @ValiantPoolC@ carrier for the+  @fused-effects@ effect system, enabling compile-time checked SQL+  queries as an algebraic effect.++  @+  import Valiant.FusedEffects++  myApp :: Has Valiant sig m => m [User]+  myApp = do+    users <- fetchAllF listUsers ()+    pure users++  main :: IO ()+  main = do+    pool <- newPool defaultPoolConfig { poolConnString = "..." }+    result <- runValiantPool pool myApp+    print result+  @+license:         BSD-3-Clause+license-file:    LICENSE+author:          Josh Burgess+maintainer:      joshburgess.webdev@gmail.com+category:        Database+homepage:        https://github.com/joshburgess/valiant+bug-reports:     https://github.com/joshburgess/valiant/issues+build-type:      Simple+extra-doc-files:+  README.md+  CHANGELOG.md+tested-with:     GHC ==9.10.3++source-repository head+  type:     git+  location: https://github.com/joshburgess/valiant+  subdir:   adapters/valiant-fused-effects++flag werror+  description: Enable -Werror for development builds.+  default:     False+  manual:      True++common warnings+  ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors -funbox-strict-fields -fspecialise-aggressively+  if flag(werror)+    ghc-options: -Werror++library+  import:           warnings+  hs-source-dirs:   src+  default-language: GHC2021+  default-extensions:+    DerivingStrategies+    FlexibleContexts+    FlexibleInstances+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    OverloadedStrings+    ScopedTypeVariables+    StrictData+    TypeOperators+    UndecidableInstances++  exposed-modules:+    Valiant.FusedEffects++  build-depends:+    , base            >=4.17 && <5+    , fused-effects   >=1.1  && <1.3+    , valiant         >=0.1  && <0.2+    , pg-wire         >=0.1  && <0.2++test-suite valiant-fused-effects-test+  import:           warnings+  type:             exitcode-stdio-1.0+  hs-source-dirs:   test+  main-is:          Main.hs+  default-language: GHC2021+  default-extensions:+    OverloadedStrings++  ghc-options: -rtsopts "-with-rtsopts=-K8K"++  other-modules:+    TestSupport++  build-depends:+    , base            >=4.17 && <5+    , bytestring      >=0.11 && <0.13+    , fused-effects   >=1.1  && <1.3+    , hspec           >=2.11 && <2.13+    , valiant+    , valiant-fused-effects+    , pg-wire+    , text            >=2.0  && <2.2