diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,177 @@ +# effectful-2.7.0.0 (2026-08-24) +* Add `OsPath` variants of the `FilePath` based APIs + (`Effectful.FileSystem.OsPath` for `System.Directory.OsPath` and + `Effectful.FileSystem.File.OsPath` for `System.File.OsPath` from the + `file-io` package). +* `runInBoundThread` and `runInUnboundThread` from `Effectful.Concurrent` no + longer run the computation in a cloned environment, so changes to thread-local + effects made within are no longer discarded. +* Add the `Input` effect (`Effectful.Input.Dynamic`, `Effectful.Input.Static`, + `Effectful.Input.Static.Action` and `Effectful.Labeled.Input`) for access to + values. +* Add the `Output` effect (`Effectful.Output.Dynamic`, + `Effectful.Output.Static.Action`, `Effectful.Output.Static.Local.Array`, + `Effectful.Output.Static.Local.List`, `Effectful.Output.Static.Shared.Array`, + `Effectful.Output.Static.Shared.List` and `Effectful.Labeled.Output`) for + accumulation of values. +* Add the `ReturnWith` effect (`Effectful.ReturnWith.Dynamic`, + `Effectful.ReturnWith.Static` and `Effectful.Labeled.ReturnWith`) for early + return from a computation. +* Re-export `Labeled(..)` from all `Effectful.Labeled.*` modules. +* Drop support for GHC < 9.6. +* Add definitions of `rethrowM` to `MonadThrow` and `catchNoPropagate` to + `MonadCatch` instances for `Eff` when appropriate (`exceptions` >= 0.10.11). +* If the cleanup action of `bracket`, `bracket_`, `bracketOnError`, `finally` or + `onException` from `Effectful.Exception` throws, the original exception is no + longer lost - it is preserved in a `WhileHandling` annotation of the new one + (`base` >= 4.21). +* Fix typo in `Effectful.Concurrent.Async.waitEitherCatchCancel`. +* Deprecate `withLiftMap` as its misuse in a multithreaded environment results + in undefined behavior that cannot be detected at runtime. Use + `localLiftUnlift` with an appropriate `UnliftStrategy` instead. +* Deprecate `stateM` and `modifyM` from `Effectful.State.Static.Local`, + `Effectful.State.Static.Shared`, `Effectful.State.Dynamic` and + `Effectful.Labeled.State` as well as the `StateM` operation of the dynamic + `State` effect. The shared variant pins the state to a lock-based + implementation, yet deadlocks when operations of the same `State` effect are + used within the callback, while the local variant silently discards state + modifications made this way. If you need atomic effectful updates of shared + state, use an explicit `MVar`. +* Deprecate `runStateMVar`, `evalStateMVar` and `execStateMVar` from + `Effectful.State.Static.Shared` so that the internal representation of the + shared `State` effect is not tied to an `MVar`. If you need access to the + state from outside of the effect, manage an explicit `MVar` yourself. +* Tighten pre-requisites for `unconsEnv` and `unreplaceEnv`. +* Add `localLendBorrow` to `Effectful.Dispatch.Dynamic`. +* Add `rethrowErrorWith`, `rethrowError` and `rethrowError_` (along with the + corresponding `RethrowErrorWith` operation of the dynamic `Error` effect) for + throwing errors with a given `CallStack`. +* Document why the `MonadThrow`, `MonadCatch` and `MonadMask` instances for + `Eff` are available without any effect requirements. +* Require `primitive` >= 0.9.0.0. +* Require `strict-mutable-base` >= 2.0.0.0. +* Remove `SharedSuffix` constraints from functions in + `Effectful.Dispatch.Dynamic` and deprecate the class, as runtime sanity + checks make it unnecessary. +* **Breaking changes**: + - Remove the `handlerEs` type parameter of `LocalEnv` as it was only needed + to support `SharedSuffix` constraints. + - Remove the `KnownEffects` class as it's no longer used; handlers of the + `ProviderList` effect now require the `KnownSubset` constraint instead. + - Drop ticks from the API of `Effectful.Concurrent.Chan.Strict`, + `Effectful.Concurrent.MVar.Strict` and `Effectful.Prim.IORef.Strict` to + match `strict-mutable-base` 2.0.0.0. +* **Bugfixes**: + - `restoreStorageData` no longer shrinks the capacity of the storage, which + could result in out of bounds reads when out of date references to the + environment were accessed after the rollback, e.g. by the unlifting function + that escaped its scope. + - Unlifting functions created by `localLiftUnlift` with `SeqForkUnlift` or + `ConcUnlift` `Persistent` strategy now correctly share the effect storage + and the thread limit now applies jointly to both functions. + - `OnEmptyRollback` strategy of the `NonDet` effect now correctly rolls back + local state of statically dispatched effects stored in mutable variables. + - Thread registration in unlifting functions created with the `ConcUnlift` + `Persistent` strategy interrupted by an asynchronous exception no longer + leaks a finalizer that corrupts the thread limit accounting when the thread + dies. + - Running the computation given to the setup function of `reinterpret` or + `impose` in a cloned environment (e.g. by unlifting it with the + `SeqForkUnlift` strategy and running it outside of the scope of the setup + function) now results in an immediate, accurate error instead of + corruption of the environment of the call site. + +# effectful-2.6.1.0 (2025-08-30) +* Add `MonadError`, `MonadReader`, `MonadState` and `MonadWriter` instances for + `Eff` for compatibility with existing code. +* Re-export `writeTMVar` from `stm-2.5.1.0` in `Effectful.Concurrent.STM`. +* Add `cancelMany` to `Effectful.Concurrent.Async`. + +# effectful-core-2.6.0.0 (2025-06-13) +* Adjust `generalBracket` with `base >= 4.21` to make use of the new exception + annotation mechanism. +* Add `withException` to `Effectful.Exception`. +* Deprecate `Effectful.Reader.Dynamic.withReader` as it doesn't work correctly + for all potential interpreters. +* Re-export `ThreadId` from `Effectful.Concurrent` for convenience. +* **Breaking changes**: + - Change the order of type parameters in `raise` for better usability. + - `Effectful.Error.Static.ErrorWrapper` is no longer caught by `catchSync`. + - Remove deprecated function `Effectful.withConcEffToIO`. + +# effectful-2.5.1.0 (2024-11-27) +* Add `passthrough` to `Effectful.Dispatch.Dynamic` for passing operations to + the upstream handler within `interpose` and `impose` without having to fully + pattern match on them. +* **Bugfixes**: + - Fix a potential space leak related to `HasCallStack` quirks (see + https://gitlab.haskell.org/ghc/ghc/-/issues/25520 for more information). + +# effectful-2.5.0.0 (2024-10-23) +* Add `plusEff` (specialized version of `<|>`) to `Effectful.NonDet` and make + `emptyEff` and `sumEff` generate better call stacks. +* Explicitly define `setByteArray#` and `setOffAddr#` in the `Prim` instance of + `Ref` for `primitive` < 0.9.0.0. +* **Bugfixes**: + - `OnEmptyRollback` strategy of the `NonDet` effect is no longer broken. +* **Breaking changes**: + - Remove `restoreEnv` function from `Effectful.Dispatch.Static.Primitive` + since it was broken. + - Base `Effectful.Exception` on `Control.Exception` instead of the + `safe-exceptions` library for consistency with provided `MonadThrow` and + `MonadCatch` instances. + +# effectful-2.4.0.0 (2024-10-08) +* Add utility functions for handling effects that take the effect handler as the + last parameter to `Effectful.Dispatch.Dynamic`. +* Add utility functions for handling first order effects to + `Effectful.Dispatch.Dynamic`. +* Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`, + `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and + `Effectful.Labeled.Writer`. +* Add `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and + `Effectful.Error.Dynamic`. +* Add `HasCallStack` constraints where appropriate for better debugging + experience. +* Add a `SeqForkUnlift` strategy to support running unlifting functions outside + of the scope of effects they capture. +* Add `Effectful.Exception` with appropriate re-exports from the + `safe-exceptions` library. +* Add `Effectful.Concurrent.Chan.Strict`. +* Add `Effectful.Prim.IORef` and `Effectful.Prim.IORef.Strict`. +* **Bugfixes**: + - Ensure that a `LocalEnv` is only used in a thread it belongs to. + - Properly roll back changes made to the environment when `OnEmptyRollback` + policy for the `NonDet` effect is selected. + - Fix a bug in `stateM` and `modifyM` of thread local `State` effect that + might've caused dropped state updates + ([#237](https://github.com/haskell-effectful/effectful/issues/237)). +* **Breaking changes**: + - `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` now take a + list of effects instead of a single one. + - `Effectful.Error.Static.throwError` now requires the error type to have a + `Show` constraint. If this is not the case for some of your error types, use + `throwError_` for them. + - `ThrowError` operation from the dynamic version of the `Error` effect was + replaced with `ThrowErrorWith`. + - `stateEnv` and `modifyEnv` now take pure modification functions. If you rely + on their old forms, switch to a combination of `getEnv` and `putEnv`. + - `runStateMVar`, `evalStateMVar` and `execStateMVar` now take a strict + `MVar'` from the `strict-mutable-base` package. + - `Effectful.Concurrent.MVar.Strict` is now a lifted version of + `Control.Concurrent.MVar.Strict` from `strict-mutable-base`. The original + module was renamed to `Effectful.Concurrent.MVar.Strict.Compat` and + deprecated. + +# effectful-2.3.1.0 (2024-06-07) +* Drop support for GHC 8.8. +* Remove inaccurate information from the `Show` instance of `ErrorWrapper`. +* Add `Effectful.Provider.List`, generalization of `Effectful.Provider`. +* Respect `withFrozenCallStack` used by callers of `send`. +* Support exchange of effects between the environment of the handler and the + local one via `localSeqLend`, `localLend`, `localSeqBorrow` and `localBorrow` + from `Effectful.Dispatch.Dynamic`. + # effectful-2.3.0.0 (2023-09-13) * Deprecate `withConcEffToIO`. * Make `withEffToIO` take an explicit unlifting strategy for the sake of diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,12 @@ # effectful -[![Build Status](https://github.com/haskell-effectful/effectful/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/haskell-effectful/effectful/actions?query=branch%3Amaster) +[![CI](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/haskell-effectful/effectful/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/effectful.svg)](https://hackage.haskell.org/package/effectful) -[![Dependencies](https://img.shields.io/hackage-deps/v/effectful.svg)](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net) [![Stackage LTS](https://www.stackage.org/package/effectful/badge/lts)](https://www.stackage.org/lts/package/effectful) [![Stackage Nightly](https://www.stackage.org/package/effectful/badge/nightly)](https://www.stackage.org/nightly/package/effectful) - + An easy to use, fast extensible effects library with seamless integration with the existing Haskell ecosystem. @@ -161,7 +160,8 @@ For the examples see the *Introduction* sections of [`Effectful.Dispatch.Dynamic`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Dynamic.html) and -[`Effectful.Dispatch.Static`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Static.html). +[`Effectful.Dispatch.Static`](https://hackage.haskell.org/package/effectful-core/docs/Effectful-Dispatch-Static.html) +(when in doubt, start with dynamic dispatch). ## Acknowledgements diff --git a/bench/Concurrency.hs b/bench/Concurrency.hs --- a/bench/Concurrency.hs +++ b/bench/Concurrency.hs @@ -9,45 +9,58 @@ import Test.Tasty.Bench hiding (env) #endif +import Control.Concurrent import Control.Concurrent.Async import Control.Monad -import qualified Effectful.Concurrent.Async as A import Effectful +import Effectful.Concurrent.Async qualified as A +import Effectful.Concurrent.STM import Effectful.Dispatch.Dynamic import Utils concurrencyBenchmark :: Benchmark concurrencyBenchmark = bgroup "concurrency" - [ bgroup "shallow" $ map shallowBench [1, 10, 100] - , bgroup "deep" $ map deepBench [1, 10, 100] + [ bgroup "shallow" $ + [ bench "MultiFork" $ nfAppIO (runShallow . testMultiFork) 1000 + ] ++ map shallowBenchUnmask [1, 10, 100] + , bgroup "deep" $ + [ bench "MultiFork" $ nfAppIO (runDeep . testMultiFork) 1000 + ] ++ map deepBenchUnmask [1, 10, 100] ] -shallowBench :: Int -> Benchmark -shallowBench n = bgroup ("unmask " ++ show n ++ "x") +testMultiFork :: IOE :> es => Int -> Eff es () +testMultiFork threads = runConcurrent $ do + v <- newTVarIO 0 + withEffToIO (ConcUnlift Persistent $ Limited threads) $ \unlift -> do + replicateM_ threads . liftIO . forkIO . unlift . atomically $ modifyTVar' v (+1) + atomically $ do + acc <- readTVar v + when (acc < threads) retry + +---------------------------------------- + +shallowBenchUnmask :: Int -> Benchmark +shallowBenchUnmask n = bgroup ("unmask " ++ show n ++ "x") [ bench "async (IO)" $ nfAppIO (asyncBenchIO n) op , bench "async (Eff)" $ nfAppIO (runShallow . A.runConcurrent . asyncBench n) op , bench "Fork (localUnliftIO/withLiftMapIO)" $ nfAppIO (runShallow . runFork1 . forkBench n) op - , bench "Fork (localUnlift/withLiftMap)" $ - nfAppIO (runShallow . runFork2 . forkBench n) op , bench "Fork (localLiftUnliftIO)" $ - nfAppIO (runShallow . runFork3 . forkBench n) op + nfAppIO (runShallow . runFork2 . forkBench n) op , bench "Fork (localLiftUnlift)" $ - nfAppIO (runShallow . runFork4 . forkBench n) op + nfAppIO (runShallow . runFork3 . forkBench n) op ] -deepBench :: Int -> Benchmark -deepBench n = bgroup ("unmask " ++ show n ++ "x") +deepBenchUnmask :: Int -> Benchmark +deepBenchUnmask n = bgroup ("unmask " ++ show n ++ "x") [ bench "async (Eff)" $ nfAppIO (runDeep . A.runConcurrent . asyncBench n) op , bench "Fork (localUnliftIO/withLiftMapIO)" $ nfAppIO (runDeep . runFork1 . forkBench n) op - , bench "Fork (localUnlift/withLiftMap)" $ - nfAppIO (runDeep . runFork2 . forkBench n) op , bench "Fork (localLiftUnliftIO)" $ - nfAppIO (runDeep . runFork3 . forkBench n) op + nfAppIO (runDeep . runFork2 . forkBench n) op , bench "Fork (localLiftUnlift)" $ - nfAppIO (runDeep . runFork4 . forkBench n) op + nfAppIO (runDeep . runFork3 . forkBench n) op ] op :: Monad m => m Int @@ -67,23 +80,16 @@ localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask --- | Uses 'localUnlift' and 'withLiftMap'. -runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a -runFork2 = reinterpret A.runConcurrent $ \env -> \case - ForkWithUnmask m -> withLiftMap env $ \liftMap -> do - localUnlift env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do - A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask - -- | Uses 'localLiftUnliftIO'. -runFork3 :: IOE :> es => Eff (Fork : es) a -> Eff es a -runFork3 = interpret $ \env -> \case +runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a +runFork2 = interpret $ \env -> \case ForkWithUnmask m -> do localLiftUnliftIO env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift -- | Uses 'localLiftUnlift'. -runFork4 :: IOE :> es => Eff (Fork : es) a -> Eff es a -runFork4 = reinterpret A.runConcurrent $ \env -> \case +runFork3 :: IOE :> es => Eff (Fork : es) a -> Eff es a +runFork3 = reinterpret A.runConcurrent $ \env -> \case ForkWithUnmask m -> do localLiftUnlift env (ConcUnlift Persistent $ Limited 1) $ \lift unlift -> do A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift diff --git a/bench/Countdown.hs b/bench/Countdown.hs --- a/bench/Countdown.hs +++ b/bench/Countdown.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +-- The deprecated stateM and StateM need to be benchmarked until they're +-- removed. +{-# OPTIONS_GHC -Wno-deprecations #-} module Countdown where import Control.Monad.ST @@ -6,51 +9,51 @@ -- eff #ifdef VERSION_eff -import qualified Control.Effect as L +import Control.Effect qualified as L #endif -- cleff #ifdef VERSION_cleff -import qualified Cleff as C -import qualified Cleff.Reader as C -import qualified Cleff.State as C +import Cleff qualified as C +import Cleff.Reader qualified as C +import Cleff.State qualified as C #endif -- effectful -import qualified Effectful as E -import qualified Effectful.Dispatch.Dynamic as E -import qualified Effectful.Labeled as E -import qualified Effectful.Reader.Static as E -import qualified Effectful.State.Dynamic as ED -import qualified Effectful.State.Static.Local as EL -import qualified Effectful.State.Static.Shared as ES +import Effectful qualified as E +import Effectful.Dispatch.Dynamic qualified as E +import Effectful.Labeled qualified as E +import Effectful.Reader.Static qualified as E +import Effectful.State.Dynamic qualified as ED +import Effectful.State.Static.Local qualified as EL +import Effectful.State.Static.Shared qualified as ES -- freer-simple #ifdef VERSION_freer_simple -import qualified Control.Monad.Freer as FS -import qualified Control.Monad.Freer.Reader as FS -import qualified Control.Monad.Freer.State as FS +import Control.Monad.Freer qualified as FS +import Control.Monad.Freer.Reader qualified as FS +import Control.Monad.Freer.State qualified as FS #endif -- fused-effects #ifdef VERSION_fused_effects -import qualified Control.Algebra as FE -import qualified Control.Carrier.Reader as FE -import qualified Control.Carrier.State.Strict as FE +import Control.Algebra qualified as FE +import Control.Carrier.Reader qualified as FE +import Control.Carrier.State.Strict qualified as FE #endif -- mtl #ifdef VERSION_mtl -import qualified Control.Monad.Reader as M -import qualified Control.Monad.State as M +import Control.Monad.Reader qualified as M +import Control.Monad.State qualified as M import Data.Functor.Identity #endif -- polysemy #ifdef VERSION_polysemy -import qualified Polysemy as P -import qualified Polysemy.Reader as P -import qualified Polysemy.State as P +import Polysemy qualified as P +import Polysemy.Reader qualified as P +import Polysemy.State qualified as P #endif ---------------------------------------- @@ -95,11 +98,11 @@ programMtl {-# NOINLINE programMtl #-} -countdownMtl :: Integer -> (Integer, Integer) -countdownMtl n = flip M.runState n $ programMtl +countdownMtlTransformers :: Integer -> (Integer, Integer) +countdownMtlTransformers n = flip M.runState n $ programMtl -countdownMtlDeep :: Integer -> (Integer, Integer) -countdownMtlDeep n = runIdentity +countdownMtlTransformersDeep :: Integer -> (Integer, Integer) +countdownMtlTransformersDeep n = runIdentity . runR . runR . runR . runR . runR . flip M.runStateT n . runR . runR . runR . runR . runR @@ -107,6 +110,18 @@ where runR = flip M.runReaderT () +countdownMtlEffectful :: Integer -> (Integer, Integer) +countdownMtlEffectful n = E.runPureEff . ED.runStateLocal n $ programMtl + +countdownMtlEffectfulDeep :: Integer -> (Integer, Integer) +countdownMtlEffectfulDeep n = E.runPureEff + . runR . runR . runR . runR . runR + . ED.runStateLocal n + . runR . runR . runR . runR . runR + $ programMtl + where + runR = E.runReader () + #endif ---------------------------------------- @@ -282,6 +297,47 @@ . runDoubleStateShared n . runR . runR . runR . runR . runR $ programEffectfulDynamic + where + runR = E.runReader () + +---------------------------------------- +-- effectful (labeled-dynamic-send) + +programEffectfulLabeledDynamicSend + :: E.Labeled "s" (ED.State Integer) E.:> es + => E.Eff es Integer +programEffectfulLabeledDynamicSend = do + n <- E.send . E.Labeled @"s" $ ED.Get @Integer + if n <= 0 + then pure n + else do + E.send . E.Labeled @"s" $ ED.Put (n - 1) + programEffectfulLabeledDynamicSend +{-# NOINLINE programEffectfulLabeledDynamicSend #-} + +countdownEffectfulLabeledDynSendLocal :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendLocal n = + E.runPureEff . E.runLabeled @"s" (ED.runStateLocal n) $ programEffectfulLabeledDynamicSend + +countdownEffectfulLabeledDynSendShared :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendShared n = + E.runPureEff . E.runLabeled @"s" (ED.runStateShared n) $ programEffectfulLabeledDynamicSend + +countdownEffectfulLabeledDynSendLocalDeep :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendLocalDeep n = E.runPureEff + . runR . runR . runR . runR . runR + . E.runLabeled @"s" (ED.runStateLocal n) + . runR . runR . runR . runR . runR + $ programEffectfulLabeledDynamicSend + where + runR = E.runReader () + +countdownEffectfulLabeledDynSendSharedDeep :: Integer -> (Integer, Integer) +countdownEffectfulLabeledDynSendSharedDeep n = E.runPureEff + . runR . runR . runR . runR . runR + . E.runLabeled @"s" (ED.runStateShared n) + . runR . runR . runR . runR . runR + $ programEffectfulLabeledDynamicSend where runR = E.runReader () diff --git a/bench/FileSizes.hs b/bench/FileSizes.hs --- a/bench/FileSizes.hs +++ b/bench/FileSizes.hs @@ -1,59 +1,59 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FieldSelectors #-} module FileSizes where import Control.Exception import Control.Monad.IO.Class import Data.IORef import Data.Text (Text) +import Data.Text qualified as T import System.Posix -import qualified Data.Text as T -- effectful -import qualified Effectful as E -import qualified Effectful.Dispatch.Dynamic as E -import qualified Effectful.Reader.Static as E -import qualified Effectful.State.Static.Local as E +import Effectful qualified as E +import Effectful.Dispatch.Dynamic qualified as E +import Effectful.Reader.Static qualified as E +import Effectful.State.Static.Local qualified as E -- eff #ifdef VERSION_eff -import qualified Control.Effect as L +import Control.Effect qualified as L #endif -- cleff #ifdef VERSION_cleff -import qualified Cleff as C -import qualified Cleff.Reader as C -import qualified Cleff.State as C +import Cleff qualified as C +import Cleff.Reader qualified as C +import Cleff.State qualified as C #endif -- freer-simple #ifdef VERSION_freer_simple -import qualified Control.Monad.Freer as FS -import qualified Control.Monad.Freer.Reader as FS -import qualified Control.Monad.Freer.State as FS +import Control.Monad.Freer qualified as FS +import Control.Monad.Freer.Reader qualified as FS +import Control.Monad.Freer.State qualified as FS #endif -- fused-effects #ifdef VERSION_fused_effects -import qualified Control.Algebra as FE -import qualified Control.Effect.Sum as FE -import qualified Control.Carrier.Reader as FE -import qualified Control.Carrier.State.Strict as FE +import Control.Algebra qualified as FE +import Control.Effect.Sum qualified as FE +import Control.Carrier.Reader qualified as FE +import Control.Carrier.State.Strict qualified as FE #endif -- mtl #ifdef VERSION_mtl -import qualified Control.Monad.State as M -import qualified Control.Monad.Reader as M +import Control.Monad.State qualified as M +import Control.Monad.Reader qualified as M #endif -- polysemy #ifdef VERSION_polysemy -import qualified Polysemy as P -import qualified Polysemy.Reader as P -import qualified Polysemy.State as P +import Polysemy qualified as P +import Polysemy.Reader qualified as P +import Polysemy.State qualified as P #endif tryGetFileSize :: FilePath -> IO (Maybe Int) @@ -102,7 +102,7 @@ effectful_tryFileSize = E.send . Effectful_tryFileSize effectful_runFile :: E.IOE E.:> es => E.Eff (Effectful_File : es) a -> E.Eff es a -effectful_runFile = E.interpret \_ -> \case +effectful_runFile = E.interpret_ \case Effectful_tryFileSize path -> liftIO $ tryGetFileSize path data Effectful_Logging :: E.Effect where @@ -116,7 +116,7 @@ effectful_runLogging :: E.Eff (Effectful_Logging : es) a -> E.Eff es (a, [Text]) -effectful_runLogging = E.reinterpret (E.runState []) \_ -> \case +effectful_runLogging = E.reinterpret_ (E.runState []) \case Effectful_logMsg msg -> E.modify (msg :) ---------- @@ -363,7 +363,7 @@ fe_tryFileSize = FE.send . FE_tryFileSize newtype FE_FileC m a = FE_FileC { fe_runFileC :: m a } - deriving (Applicative, Functor, Monad, MonadIO) + deriving newtype (Applicative, Functor, Monad, MonadIO) instance ( MonadIO m @@ -380,7 +380,7 @@ fe_logMsg = FE.send . FE_logMsg . T.pack newtype FE_LoggingC m a = FE_LoggingC { fe_runLoggingC :: FE.StateC [Text] m a } - deriving (Applicative, Functor, Monad) + deriving newtype (Applicative, Functor, Monad) instance ( FE.Algebra sig m @@ -439,8 +439,11 @@ class Monad m => MonadFile m where mtl_tryFileSize :: FilePath -> m (Maybe Int) +instance Effectful_File E.:> es => MonadFile (E.Eff es) where + mtl_tryFileSize = effectful_tryFileSize + newtype FileT m a = FileT { runFileT :: m a } - deriving (Functor, Applicative, Monad, MonadIO) + deriving newtype (Functor, Applicative, Monad, MonadIO) instance M.MonadTrans FileT where lift = FileT @@ -458,8 +461,11 @@ class Monad m => MonadLog m where mtl_logMsg :: String -> m () +instance Effectful_Logging E.:> es => MonadLog (E.Eff es) where + mtl_logMsg = effectful_logMsg + newtype LoggingT m a = LoggingT (M.StateT [Text] m a) - deriving (Functor, Applicative, Monad, MonadIO, M.MonadTrans) + deriving newtype (Functor, Applicative, Monad, MonadIO, M.MonadTrans) instance {-# OVERLAPPABLE #-} ( MonadLog m @@ -492,17 +498,30 @@ pure $ sum sizes {-# NOINLINE mtl_program #-} -mtl_calculateFileSizes :: [FilePath] -> IO (Int, [Text]) -mtl_calculateFileSizes = runFileT . runLoggingT . mtl_program +mtl_calculateFileSizesTransformers :: [FilePath] -> IO (Int, [Text]) +mtl_calculateFileSizesTransformers = runFileT . runLoggingT . mtl_program -mtl_calculateFileSizesDeep :: [FilePath] -> IO (Int, [Text]) -mtl_calculateFileSizesDeep +mtl_calculateFileSizesTransformersDeep :: [FilePath] -> IO (Int, [Text]) +mtl_calculateFileSizesTransformersDeep = runR . runR . runR . runR . runR . runFileT . runLoggingT . runR . runR . runR . runR . runR . mtl_program where runR = flip M.runReaderT () + +mtl_calculateFileSizesEffectful :: [FilePath] -> IO (Int, [Text]) +mtl_calculateFileSizesEffectful = + E.runEff . effectful_runFile . effectful_runLogging . mtl_program + +mtl_calculateFileSizesEffectfulDeep :: [FilePath] -> IO (Int, [Text]) +mtl_calculateFileSizesEffectfulDeep = E.runEff + . runR . runR . runR . runR . runR + . effectful_runFile . effectful_runLogging + . runR . runR . runR . runR . runR + . mtl_program + where + runR = E.runReader () #endif diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -64,6 +64,10 @@ [ bench "shallow" $ nf countdownEffectfulDynLocal n , bench "deep" $ nf countdownEffectfulDynLocalDeep n ] + , bgroup "effectful (local/dynamic/labeled/send)" + [ bench "shallow" $ nf countdownEffectfulLabeledDynSendLocal n + , bench "deep" $ nf countdownEffectfulLabeledDynSendLocalDeep n + ] , bgroup "effectful (shared/static)" [ bench "shallow" $ nf countdownEffectfulShared n , bench "deep" $ nf countdownEffectfulSharedDeep n @@ -72,6 +76,10 @@ [ bench "shallow" $ nf countdownEffectfulDynShared n , bench "deep" $ nf countdownEffectfulDynSharedDeep n ] + , bgroup "effectful (shared/dynamic/labeled/send)" + [ bench "shallow" $ nf countdownEffectfulLabeledDynSendShared n + , bench "deep" $ nf countdownEffectfulLabeledDynSendSharedDeep n + ] #ifdef VERSION_cleff , bgroup "cleff (local)" [ bench "shallow" $ nf countdownCleffLocal n @@ -95,10 +103,14 @@ ] #endif #ifdef VERSION_mtl - , bgroup "mtl" - [ bench "shallow" $ nf countdownMtl n - , bench "deep" $ nf countdownMtlDeep n + , bgroup "mtl (effectful)" + [ bench "shallow" $ nf countdownMtlEffectful n + , bench "deep" $ nf countdownMtlEffectfulDeep n ] + , bgroup "mtl (transformers)" + [ bench "shallow" $ nf countdownMtlTransformers n + , bench "deep" $ nf countdownMtlTransformersDeep n + ] #endif #ifdef VERSION_fused_effects , bgroup "fused-effects" @@ -140,9 +152,13 @@ ] #endif #ifdef VERSION_mtl - , bgroup "mtl" - [ bench "shallow" $ nfAppIO mtl_calculateFileSizes (take n files) - , bench "deep" $ nfAppIO mtl_calculateFileSizesDeep (take n files) + , bgroup "mtl (effectful)" + [ bench "shallow" $ nfAppIO mtl_calculateFileSizesEffectful (take n files) + , bench "deep" $ nfAppIO mtl_calculateFileSizesEffectfulDeep (take n files) + ] + , bgroup "mtl (transformers)" + [ bench "shallow" $ nfAppIO mtl_calculateFileSizesTransformers (take n files) + , bench "deep" $ nfAppIO mtl_calculateFileSizesTransformersDeep (take n files) ] #endif #ifdef VERSION_fused_effects diff --git a/bench/Unlift.hs b/bench/Unlift.hs --- a/bench/Unlift.hs +++ b/bench/Unlift.hs @@ -9,12 +9,12 @@ import Test.Tasty.Bench #endif -import qualified UnliftIO as U +import UnliftIO qualified as U import Effectful +import Effectful.Concurrent.Async qualified as A import Effectful.State.Dynamic import Utils -import qualified Effectful.Concurrent.Async as A unliftBenchmark :: Benchmark unliftBenchmark = bgroup "unlifting" diff --git a/effectful.cabal b/effectful.cabal --- a/effectful.cabal +++ b/effectful.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.4 +cabal-version: 3.8 build-type: Simple name: effectful -version: 2.3.0.0 +version: 2.7.0.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -12,7 +12,7 @@ description: An easy to use, performant extensible effects library with seamless integration with the existing Haskell ecosystem. - . + This is the "batteries-included" variant. See the @@ package if you need a more limited dependency footprint or want to browse @@ -22,8 +22,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.2 - || ==9.8.1 +tested-with: GHC == { 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 } bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head @@ -35,44 +34,39 @@ default: False common language - ghc-options: -Wall -Wcompat -Wno-unticked-promoted-constructors + ghc-options: -Wall + -Wcompat + -Wmissing-deriving-strategies + -Werror=prepositive-qualified-module - default-language: Haskell2010 + default-language: GHC2021 - default-extensions: BangPatterns - ConstraintKinds - DataKinds - DeriveFunctor - DeriveGeneric - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving + default-extensions: DataKinds + DeepSubsumption + DerivingStrategies + DuplicateRecordFields LambdaCase - MultiParamTypeClasses + NoFieldSelectors NoStarIsType - RankNTypes - RecordWildCards + OverloadedRecordDot RoleAnnotations - ScopedTypeVariables - StandaloneDeriving - TupleSections - TypeApplications TypeFamilies - TypeOperators + UndecidableInstances library import: language - build-depends: base >= 4.13 && < 5 - , async >= 2.2.2 + build-depends: base >= 4.18 && < 5 + , async >= 2.2.5 , bytestring >= 0.10 - , directory >= 1.3.2 - , effectful-core >= 2.3.0.0 && < 2.3.1.0 + , directory >= 1.3.8 + , effectful-core >= 2.7.0.0 && < 2.7.1.0 + , file-io >= 0.1.4 + , filepath >= 1.4.100 , process >= 1.6.9 - + , strict-mutable-base >= 2.0.0.0 && < 3 , time >= 1.9.2 - , stm >= 2.5.0.0 + , stm >= 2.5.1.0 , unliftio >= 0.2.20 hs-source-dirs: src @@ -80,8 +74,10 @@ exposed-modules: Effectful.Concurrent Effectful.Concurrent.Async Effectful.Concurrent.Chan + Effectful.Concurrent.Chan.Strict Effectful.Concurrent.MVar Effectful.Concurrent.MVar.Strict + Effectful.Concurrent.MVar.Strict.Compat Effectful.Concurrent.STM Effectful.Concurrent.QSem Effectful.Concurrent.QSemN @@ -89,11 +85,15 @@ Effectful.Console.ByteString.Lazy Effectful.Environment Effectful.FileSystem + Effectful.FileSystem.File.OsPath Effectful.FileSystem.IO Effectful.FileSystem.IO.ByteString Effectful.FileSystem.IO.ByteString.Builder Effectful.FileSystem.IO.ByteString.Lazy Effectful.FileSystem.IO.File + Effectful.FileSystem.OsPath + Effectful.Prim.IORef + Effectful.Prim.IORef.Strict Effectful.Process Effectful.Temporary Effectful.Timeout @@ -105,15 +105,35 @@ reexported-modules: Effectful , Effectful.Dispatch.Dynamic , Effectful.Dispatch.Static - , Effectful.Error.Static , Effectful.Error.Dynamic + , Effectful.Error.Static + , Effectful.Exception , Effectful.Fail + , Effectful.Input.Dynamic + , Effectful.Input.Static + , Effectful.Input.Static.Action , Effectful.Labeled + , Effectful.Labeled.Error + , Effectful.Labeled.Input + , Effectful.Labeled.Output + , Effectful.Labeled.Reader + , Effectful.Labeled.ReturnWith + , Effectful.Labeled.State + , Effectful.Labeled.Writer , Effectful.NonDet + , Effectful.Output.Dynamic + , Effectful.Output.Static.Action + , Effectful.Output.Static.Local.Array + , Effectful.Output.Static.Local.List + , Effectful.Output.Static.Shared.Array + , Effectful.Output.Static.Shared.List , Effectful.Prim , Effectful.Provider + , Effectful.Provider.List , Effectful.Reader.Dynamic , Effectful.Reader.Static + , Effectful.ReturnWith.Dynamic + , Effectful.ReturnWith.Static , Effectful.State.Dynamic , Effectful.State.Static.Local , Effectful.State.Static.Shared @@ -124,15 +144,23 @@ test-suite test import: language + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial + ghc-options: -threaded -rtsopts -with-rtsopts=-N4 build-depends: base + , bytestring , containers , effectful , effectful-core , exceptions + , filepath , lifted-base , primitive + , random + , safe-exceptions + , strict-mutable-base , tasty , tasty-hunit , unliftio @@ -147,13 +175,20 @@ EnvTests EnvironmentTests ErrorTests + ExceptionTests + FileSystemTests + InputTests + LabeledTests NonDetTests + OutputTests PrimTests ReaderTests + ReturnWithTests StateTests TimeoutTests UnliftTests Utils + Word64MapTests benchmark bench import: language @@ -169,11 +204,11 @@ if impl(ghc < 9.9) build-depends: freer-simple >= 1.2.1.2 - if impl(ghc < 9.9) - build-depends: fused-effects >= 1.1.2.2 + if impl(ghc < 9.15) + build-depends: fused-effects >= 1.1.2.3 - if impl(ghc < 9.7) - build-depends: polysemy >= 1.9.1.0 + if impl(ghc < 9.15) + build-depends: polysemy >= 1.9.2.0 build-depends: base , async diff --git a/src/Effectful/Concurrent.hs b/src/Effectful/Concurrent.hs --- a/src/Effectful/Concurrent.hs +++ b/src/Effectful/Concurrent.hs @@ -20,6 +20,7 @@ , runConcurrent -- * Basic concurrency operations + , C.ThreadId , myThreadId , forkIO , forkFinally @@ -59,13 +60,13 @@ , C.rtsSupportsBoundThreads ) where +import Control.Concurrent qualified as C import Control.Exception (Exception, SomeException) import Data.Bifunctor (second) +import GHC.Conc qualified as GHC import System.Mem.Weak (Weak) import System.Posix.Types (Fd) import UnliftIO.STM (STM) -import qualified Control.Concurrent as C -import qualified GHC.Conc as GHC import Effectful import Effectful.Concurrent.Effect @@ -81,14 +82,14 @@ myThreadId = unsafeEff_ C.myThreadId -- | Lifted 'C.forkIO'. -forkIO :: Concurrent :> es => Eff es () -> Eff es C.ThreadId +forkIO :: (HasCallStack, Concurrent :> es) => Eff es () -> Eff es C.ThreadId forkIO k = unsafeEff $ \es -> do esF <- cloneEnv es C.forkIO $ unEff k esF -- | Lifted 'C.forkFinally'. forkFinally - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Eff es a -> (Either SomeException a -> Eff es ()) -> Eff es C.ThreadId @@ -98,7 +99,7 @@ -- | Lifted 'C.forkIOWithUnmask'. forkIOWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId forkIOWithUnmask = liftForkWithUnmask C.forkIOWithUnmask @@ -115,14 +116,14 @@ -- Threads with affinity -- | Lifted 'C.forkOn'. -forkOn :: Concurrent :> es => Int -> Eff es () -> Eff es C.ThreadId +forkOn :: (HasCallStack, Concurrent :> es) => Int -> Eff es () -> Eff es C.ThreadId forkOn n k = unsafeEff $ \es -> do esF <- cloneEnv es C.forkOn n (unEff k esF) -- | Lifted 'C.forkOnWithUnmask'. forkOnWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Int -> ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId @@ -180,14 +181,14 @@ -- Bound threads -- | Lifted 'C.forkOS'. -forkOS :: Concurrent :> es => Eff es () -> Eff es C.ThreadId +forkOS :: (HasCallStack, Concurrent :> es) => Eff es () -> Eff es C.ThreadId forkOS k = unsafeEff $ \es -> do esF <- cloneEnv es C.forkOS $ unEff k esF -- | Lifted 'E.forkOSWithUnmask'. forkOSWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => ((forall a. Eff es a -> Eff es a) -> Eff es ()) -> Eff es C.ThreadId forkOSWithUnmask = liftForkWithUnmask C.forkOSWithUnmask @@ -197,16 +198,18 @@ isCurrentThreadBound = unsafeEff_ C.isCurrentThreadBound -- | Lifted 'C.runInBoundThread'. -runInBoundThread :: Concurrent :> es => Eff es a -> Eff es a -runInBoundThread k = unsafeEff $ \es -> do - esF <- cloneEnv es - C.runInBoundThread $ unEff k esF +runInBoundThread :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es a +runInBoundThread k = reallyUnsafeUnliftIO $ \unlift -> do + -- The worker thread runs the computation while the calling thread blocks, so + -- even though a different thread accesses the environment, the execution is + -- strictly sequential and sharing it is fine. + C.runInBoundThread $ unlift k -- | Lifted 'C.runInUnboundThread'. -runInUnboundThread :: Concurrent :> es => Eff es a -> Eff es a -runInUnboundThread k = unsafeEff $ \es -> do - esF <- cloneEnv es - C.runInUnboundThread $ unEff k esF +runInUnboundThread :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es a +runInUnboundThread k = reallyUnsafeUnliftIO $ \unlift -> do + -- See the comment in runInBoundThread. + C.runInUnboundThread $ unlift k ---------------------------------------- -- Weak references to ThreadIds @@ -219,7 +222,8 @@ -- Helpers liftForkWithUnmask - :: (((forall c. IO c -> IO c) -> IO a) -> IO C.ThreadId) + :: HasCallStack + => (((forall c. IO c -> IO c) -> IO a) -> IO C.ThreadId) -> ((forall c. Eff es c -> Eff es c) -> Eff es a) -> Eff es C.ThreadId liftForkWithUnmask fork action = unsafeEff $ \es -> do diff --git a/src/Effectful/Concurrent/Async.hs b/src/Effectful/Concurrent/Async.hs --- a/src/Effectful/Concurrent/Async.hs +++ b/src/Effectful/Concurrent/Async.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} -- | Lifted "Control.Concurrent.Async". module Effectful.Concurrent.Async ( -- * Effect @@ -18,7 +17,8 @@ -- ** Querying 'Async's , wait, poll, waitCatch, A.asyncThreadId - , cancel, uninterruptibleCancel, cancelWith, A.AsyncCancelled(..) + , cancel, cancelMany, uninterruptibleCancel, cancelWith + , A.AsyncCancelled(..) , A.compareAsyncs -- ** High-level utilities @@ -80,9 +80,9 @@ import Control.Exception (Exception, SomeException) import Control.Monad (forever) import Data.Kind (Type) -import qualified Control.Concurrent.Async as A -import qualified UnliftIO.Async as U -import qualified UnliftIO.Internals.Async as I +import Control.Concurrent.Async qualified as A +import UnliftIO.Async qualified as U +import UnliftIO.Internals.Async qualified as I import Effectful import Effectful.Concurrent.Effect @@ -91,27 +91,27 @@ import Effectful.Dispatch.Static.Unsafe -- | Lifted 'A.async'. -async :: Concurrent :> es => Eff es a -> Eff es (Async a) +async :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es (Async a) async = liftAsync A.async -- | Lifted 'A.asyncBound'. -asyncBound :: Concurrent :> es => Eff es a -> Eff es (Async a) +asyncBound :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es (Async a) asyncBound = liftAsync A.asyncBound -- | Lifted 'A.asyncOn'. -asyncOn :: Concurrent :> es => Int -> Eff es a -> Eff es (Async a) +asyncOn :: (HasCallStack, Concurrent :> es) => Int -> Eff es a -> Eff es (Async a) asyncOn cpu = liftAsync (A.asyncOn cpu) -- | Lifted 'A.asyncWithUnmask'. asyncWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => ((forall b. Eff es b -> Eff es b) -> Eff es a) -> Eff es (Async a) asyncWithUnmask = liftAsyncWithUnmask A.asyncWithUnmask -- | Lifted 'A.asyncOnWithUnmask'. asyncOnWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Int -> ((forall b. Eff es b -> Eff es b) -> Eff es a) -> Eff es (Async a) @@ -119,7 +119,7 @@ -- | Lifted 'A.withAsync'. withAsync - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Eff es a -> (Async a -> Eff es b) -> Eff es b @@ -127,7 +127,7 @@ -- | Lifted 'A.withAsyncBound'. withAsyncBound - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Eff es a -> (Async a -> Eff es b) -> Eff es b @@ -135,7 +135,7 @@ -- | Lifted 'A.withAsyncOn'. withAsyncOn - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Int -> Eff es a -> (Async a -> Eff es b) @@ -144,7 +144,7 @@ -- | Lifted 'A.withAsyncWithUnmask'. withAsyncWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => ((forall c. Eff es c -> Eff es c) -> Eff es a) -> (Async a -> Eff es b) -> Eff es b @@ -152,7 +152,7 @@ -- | Lifted 'A.withAsyncOnWithUnmask'. withAsyncOnWithUnmask - :: Concurrent :> es + :: (HasCallStack, Concurrent :> es) => Int -> ((forall c. Eff es c -> Eff es c) -> Eff es a) -> (Async a -> Eff es b) @@ -174,6 +174,12 @@ cancel :: Concurrent :> es => Async a -> Eff es () cancel = unsafeEff_ . A.cancel +-- | Lifted 'A.cancelMany'. +-- +-- @since 2.6.1.0 +cancelMany :: Concurrent :> es => [Async a] -> Eff es () +cancelMany = unsafeEff_ . A.cancelMany + -- | Lifted 'A.cancelWith'. cancelWith :: (Exception e, Concurrent :> es) => Async a -> e -> Eff es () cancelWith a = unsafeEff_ . A.cancelWith a @@ -241,7 +247,7 @@ => Async a -> Async b -> Eff es (Either (Either SomeException a) (Either SomeException b)) -waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatch a b +waitEitherCatchCancel a b = unsafeEff_ $ A.waitEitherCatchCancel a b -- | Lifted 'A.waitEither_'. waitEither_ :: Concurrent :> es => Async a -> Async b -> Eff es () @@ -268,22 +274,22 @@ link2Only f a b = unsafeEff_ $ A.link2Only f a b -- | Lifted 'A.race'. -race :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (Either a b) +race :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es (Either a b) race ma mb = unsafeEff $ \es -> do A.race (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) -- | Lifted 'A.race_'. -race_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es () +race_ :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es () race_ ma mb = unsafeEff $ \es -> do A.race_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) -- | Lifted 'A.concurrently'. -concurrently :: Concurrent :> es => Eff es a -> Eff es b -> Eff es (a, b) +concurrently :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es (a, b) concurrently ma mb = unsafeEff $ \es -> do A.concurrently (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) -- | Lifted 'A.concurrently_'. -concurrently_ :: Concurrent :> es => Eff es a -> Eff es b -> Eff es () +concurrently_ :: (HasCallStack, Concurrent :> es) => Eff es a -> Eff es b -> Eff es () concurrently_ ma mb = unsafeEff $ \es -> do A.concurrently_ (unEff ma =<< cloneEnv es) (unEff mb =<< cloneEnv es) @@ -293,7 +299,7 @@ -- | Lifted 'A.mapConcurrently'. mapConcurrently - :: (Traversable f, Concurrent :> es) + :: (HasCallStack, Traversable f, Concurrent :> es) => (a -> Eff es b) -> f a -> Eff es (f b) @@ -302,7 +308,7 @@ -- | Lifted 'A.mapConcurrently_'. mapConcurrently_ - :: (Foldable f, Concurrent :> es) + :: (HasCallStack, Foldable f, Concurrent :> es) => (a -> Eff es b) -> f a -> Eff es () @@ -311,7 +317,7 @@ -- | Lifted 'A.forConcurrently'. forConcurrently - :: (Traversable f, Concurrent :> es) + :: (HasCallStack, Traversable f, Concurrent :> es) => f a -> (a -> Eff es b) -> Eff es (f b) @@ -320,7 +326,7 @@ -- | Lifted 'A.forConcurrently_'. forConcurrently_ - :: (Foldable f, Concurrent :> es) + :: (HasCallStack, Foldable f, Concurrent :> es) => f a -> (a -> Eff es b) -> Eff es () @@ -328,12 +334,20 @@ U.forConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es) -- | Lifted 'A.replicateConcurrently'. -replicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a] +replicateConcurrently + :: (HasCallStack, Concurrent :> es) + => Int + -> Eff es a + -> Eff es [a] replicateConcurrently n f = unsafeEff $ \es -> do U.replicateConcurrently n (unEff f =<< cloneEnv es) -- | Lifted 'A.replicateConcurrently_'. -replicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es () +replicateConcurrently_ + :: (HasCallStack, Concurrent :> es) + => Int + -> Eff es a + -> Eff es () replicateConcurrently_ n f = unsafeEff $ \es -> do U.replicateConcurrently_ n (unEff f =<< cloneEnv es) @@ -342,7 +356,7 @@ -- | Lifted 'U.pooledMapConcurrentlyN'. pooledMapConcurrentlyN - :: (Concurrent :> es, Traversable t) + :: (HasCallStack, Concurrent :> es, Traversable t) => Int -> (a -> Eff es b) -> t a @@ -352,7 +366,7 @@ -- | Lifted 'U.pooledMapConcurrently'. pooledMapConcurrently - :: (Concurrent :> es, Traversable t) + :: (HasCallStack, Concurrent :> es, Traversable t) => (a -> Eff es b) -> t a -> Eff es (t b) @@ -361,7 +375,7 @@ -- | Lifted 'U.pooledMapConcurrentlyN'. pooledMapConcurrentlyN_ - :: (Concurrent :> es, Foldable f) + :: (HasCallStack, Concurrent :> es, Foldable f) => Int -> (a -> Eff es b) -> f a @@ -371,7 +385,7 @@ -- | Lifted 'U.pooledMapConcurrently_'. pooledMapConcurrently_ - :: (Concurrent :> es, Foldable f) + :: (HasCallStack, Concurrent :> es, Foldable f) => (a -> Eff es b) -> f a -> Eff es () @@ -380,7 +394,7 @@ -- | Lifted 'U.pooledForConcurrentlyN'. pooledForConcurrentlyN - :: (Concurrent :> es, Traversable t) + :: (HasCallStack, Concurrent :> es, Traversable t) => Int -> t a -> (a -> Eff es b) @@ -390,7 +404,7 @@ -- | Lifted 'U.pooledForConcurrently'. pooledForConcurrently - :: (Concurrent :> es, Traversable t) + :: (HasCallStack, Concurrent :> es, Traversable t) => t a -> (a -> Eff es b) -> Eff es (t b) @@ -399,7 +413,7 @@ -- | Lifted 'U.pooledForConcurrentlyN'. pooledForConcurrentlyN_ - :: (Concurrent :> es, Foldable f) + :: (HasCallStack, Concurrent :> es, Foldable f) => Int -> f a -> (a -> Eff es b) @@ -409,7 +423,7 @@ -- | Lifted 'U.pooledForConcurrently_'. pooledForConcurrently_ - :: (Concurrent :> es, Foldable f) + :: (HasCallStack, Concurrent :> es, Foldable f) => f a -> (a -> Eff es b) -> Eff es () @@ -417,22 +431,40 @@ U.pooledForConcurrently_ t (\a -> unEff (f a) =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrentlyN'. -pooledReplicateConcurrentlyN :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es [a] +pooledReplicateConcurrentlyN + :: (HasCallStack, Concurrent :> es) + => Int + -> Int + -> Eff es a + -> Eff es [a] pooledReplicateConcurrentlyN threads n f = unsafeEff $ \es -> do U.pooledReplicateConcurrentlyN threads n (unEff f =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrently'. -pooledReplicateConcurrently :: Concurrent :> es => Int -> Eff es a -> Eff es [a] +pooledReplicateConcurrently + :: (HasCallStack, Concurrent :> es) + => Int + -> Eff es a + -> Eff es [a] pooledReplicateConcurrently n f = unsafeEff $ \es -> do U.pooledReplicateConcurrently n (unEff f =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrentlyN_'. -pooledReplicateConcurrentlyN_ :: Concurrent :> es => Int -> Int -> Eff es a -> Eff es () +pooledReplicateConcurrentlyN_ + :: (HasCallStack, Concurrent :> es) + => Int + -> Int + -> Eff es a + -> Eff es () pooledReplicateConcurrentlyN_ threads n f = unsafeEff $ \es -> do U.pooledReplicateConcurrentlyN_ threads n (unEff f =<< cloneEnv es) -- | Lifted 'U.pooledReplicateConcurrently_'. -pooledReplicateConcurrently_ :: Concurrent :> es => Int -> Eff es a -> Eff es () +pooledReplicateConcurrently_ + :: (HasCallStack, Concurrent :> es) + => Int + -> Eff es a + -> Eff es () pooledReplicateConcurrently_ n f = unsafeEff $ \es -> do U.pooledReplicateConcurrently_ n (unEff f =<< cloneEnv es) @@ -448,7 +480,7 @@ Alt :: Conc es a -> Conc es a -> Conc es a Empty :: Conc es a -deriving instance Functor (Conc es) +deriving stock instance Functor (Conc es) instance Applicative (Conc es) where pure = Pure @@ -472,7 +504,7 @@ conc = Action -- | Lifted 'U.runConc'. -runConc :: Concurrent :> es => Conc es a -> Eff es a +runConc :: (HasCallStack, Concurrent :> es) => Conc es a -> Eff es a runConc m = unsafeEff $ \es -> U.runConc (unliftConc es m) where unliftConc :: Env es -> Conc es a -> U.Conc IO a @@ -513,7 +545,8 @@ -- Helpers liftAsync - :: (IO a -> IO (Async a)) + :: HasCallStack + => (IO a -> IO (Async a)) -> Eff es a -> Eff es (Async a) liftAsync fork action = unsafeEff $ \es -> do @@ -521,7 +554,8 @@ fork $ unEff action esA liftAsyncWithUnmask - :: (((forall b. IO b -> IO b) -> IO a) -> IO (Async a)) + :: HasCallStack + => (((forall b. IO b -> IO b) -> IO a) -> IO (Async a)) -> ((forall b. Eff es b -> Eff es b) -> Eff es a) -> Eff es (Async a) liftAsyncWithUnmask fork action = unsafeEff $ \es -> do @@ -530,7 +564,8 @@ fork $ \unmask -> unEff (action $ reallyUnsafeLiftMapIO unmask) esA liftWithAsync - :: (IO a -> (Async a -> IO b) -> IO b) + :: HasCallStack + => (IO a -> (Async a -> IO b) -> IO b) -> Eff es a -> (Async a -> Eff es b) -> Eff es b @@ -540,7 +575,8 @@ (\a -> unEff (k a) es) liftWithAsyncWithUnmask - :: (((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b) + :: HasCallStack + => (((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b) -> ((forall c. Eff es c -> Eff es c) -> Eff es a) -> (Async a -> Eff es b) -> Eff es b diff --git a/src/Effectful/Concurrent/Chan.hs b/src/Effectful/Concurrent/Chan.hs --- a/src/Effectful/Concurrent/Chan.hs +++ b/src/Effectful/Concurrent/Chan.hs @@ -17,7 +17,7 @@ ) where import Control.Concurrent.Chan (Chan) -import qualified Control.Concurrent.Chan as C +import Control.Concurrent.Chan qualified as C import Effectful import Effectful.Concurrent.Effect diff --git a/src/Effectful/Concurrent/Chan/Strict.hs b/src/Effectful/Concurrent/Chan/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Concurrent/Chan/Strict.hs @@ -0,0 +1,50 @@ +-- | Lifted "Control.Concurrent.Chan.Strict". +-- +-- @since 2.4.0.0 +module Effectful.Concurrent.Chan.Strict + ( -- * Effect + Concurrent + + -- ** Handlers + , runConcurrent + + -- * Chan + , Chan + , newChan + , writeChan + , readChan + , dupChan + , getChanContents + , writeList2Chan + ) where + +import Control.Concurrent.Chan.Strict (Chan) +import Control.Concurrent.Chan.Strict qualified as C + +import Effectful +import Effectful.Concurrent.Effect +import Effectful.Dispatch.Static + +-- | Lifted 'C.newChan'. +newChan :: Concurrent :> es => Eff es (Chan a) +newChan = unsafeEff_ C.newChan + +-- | Lifted 'C.writeChan'. +writeChan :: Concurrent :> es => Chan a -> a -> Eff es () +writeChan c = unsafeEff_ . C.writeChan c + +-- | Lifted 'C.readChan'. +readChan :: Concurrent :> es => Chan a -> Eff es a +readChan = unsafeEff_ . C.readChan + +-- | Lifted 'C.dupChan'. +dupChan :: Concurrent :> es => Chan a -> Eff es (Chan a) +dupChan = unsafeEff_ . C.dupChan + +-- | Lifted 'C.getChanContents'. +getChanContents :: Concurrent :> es => Chan a -> Eff es [a] +getChanContents = unsafeEff_ . C.getChanContents + +-- | Lifted 'C.writeList2Chan'. +writeList2Chan :: Concurrent :> es => Chan a -> [a] -> Eff es () +writeList2Chan c = unsafeEff_ . C.writeList2Chan c diff --git a/src/Effectful/Concurrent/Effect.hs b/src/Effectful/Concurrent/Effect.hs --- a/src/Effectful/Concurrent/Effect.hs +++ b/src/Effectful/Concurrent/Effect.hs @@ -17,7 +17,7 @@ -- it possible to escape the scope of any scoped effect operation. Consider the -- following: -- --- >>> import qualified Effectful.Reader.Static as R +-- >>> import Effectful.Reader.Static qualified as R -- -- >>> printAsk msg = liftIO . putStrLn . (msg ++) . (": " ++) =<< R.ask -- @@ -54,14 +54,14 @@ -- a mutable state. That's why statically dispatched @State@ and @Writer@ -- effects come in two flavors, local and shared: -- --- >>> import qualified Effectful.State.Static.Local as SL +-- >>> import Effectful.State.Static.Local qualified as SL -- >>> :{ -- runEff . SL.execState "Hi" . runConcurrent $ do -- replicateConcurrently_ 3 $ SL.modify (++ "!") -- :} -- "Hi" -- --- >>> import qualified Effectful.State.Static.Shared as SS +-- >>> import Effectful.State.Static.Shared qualified as SS -- >>> :{ -- runEff . SS.execState "Hi" . runConcurrent $ do -- replicateConcurrently_ 3 $ SS.modify (++ "!") @@ -78,7 +78,7 @@ data instance StaticRep Concurrent = Concurrent -- | Run the 'Concurrent' effect. -runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a +runConcurrent :: (HasCallStack, IOE :> es) => Eff (Concurrent : es) a -> Eff es a runConcurrent = evalStaticRep Concurrent -- $setup diff --git a/src/Effectful/Concurrent/MVar.hs b/src/Effectful/Concurrent/MVar.hs --- a/src/Effectful/Concurrent/MVar.hs +++ b/src/Effectful/Concurrent/MVar.hs @@ -29,7 +29,7 @@ import System.Mem.Weak (Weak) import Control.Concurrent.MVar (MVar) -import qualified Control.Concurrent.MVar as M +import Control.Concurrent.MVar qualified as M import Effectful import Effectful.Concurrent.Effect @@ -81,34 +81,47 @@ withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVar var $ unlift . f +{-# INLINE withMVar #-} -- | Lifted 'M.withMVarMasked'. withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVarMasked var $ unlift . f +{-# INLINE withMVarMasked #-} -- | Lifted 'M.modifyMVar_'. modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVar_ var $ unlift . f +{-# INLINE modifyMVar_ #-} -- | Lifted 'M.modifyMVar'. modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVar var $ unlift . f +{-# INLINE modifyMVar #-} -- | Lifted 'M.modifyMVarMasked_'. modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVarMasked_ var $ unlift . f +{-# INLINE modifyMVarMasked_ #-} -- | Lifted 'M.modifyMVarMasked'. modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.modifyMVarMasked var $ unlift . f +{-# INLINE modifyMVarMasked #-} -- | Lifted 'M.mkWeakMVar'. -mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a)) +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakMVar + :: (HasCallStack, Concurrent :> es) + => MVar a + -> Eff es () + -> Eff es (Weak (MVar a)) mkWeakMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. M.mkWeakMVar var . unEff f =<< cloneEnv es diff --git a/src/Effectful/Concurrent/MVar/Strict.hs b/src/Effectful/Concurrent/MVar/Strict.hs --- a/src/Effectful/Concurrent/MVar/Strict.hs +++ b/src/Effectful/Concurrent/MVar/Strict.hs @@ -1,5 +1,6 @@ --- | Lifted "Control.Concurrent.MVar" with operations that force values put --- inside an 'MVar' to WHNF. +-- | Lifted "Control.Concurrent.MVar.Strict". +-- +-- @since 2.4.0.0 module Effectful.Concurrent.MVar.Strict ( -- * Effect Concurrent @@ -17,6 +18,7 @@ , swapMVar , tryTakeMVar , tryPutMVar + , tryReadMVar , isEmptyMVar , withMVar , withMVarMasked @@ -24,13 +26,12 @@ , modifyMVar_ , modifyMVarMasked , modifyMVarMasked_ - , tryReadMVar , mkWeakMVar ) where import System.Mem.Weak (Weak) -import Control.Concurrent.MVar (MVar) -import qualified Control.Concurrent.MVar as M +import Control.Concurrent.MVar.Strict (MVar) +import Control.Concurrent.MVar.Strict qualified as M import Effectful import Effectful.Concurrent.Effect @@ -42,9 +43,9 @@ newEmptyMVar :: Concurrent :> es => Eff es (MVar a) newEmptyMVar = unsafeEff_ M.newEmptyMVar --- | Lifted 'M.newMVar' that evaluates the value to WHNF. +-- | Lifted 'M.newMVar'. newMVar :: Concurrent :> es => a -> Eff es (MVar a) -newMVar a = unsafeEff_ $ a `seq` M.newMVar a +newMVar = unsafeEff_ . M.newMVar -- | Lifted 'M.takeMVar'. takeMVar :: Concurrent :> es => MVar a -> Eff es a @@ -52,72 +53,76 @@ -- | Lifted 'M.putMVar'. putMVar :: Concurrent :> es => MVar a -> a -> Eff es () -putMVar var a = unsafeEff_ $ a `seq` M.putMVar var a +putMVar var = unsafeEff_ . M.putMVar var -- | Lifted 'M.readMVar'. readMVar :: Concurrent :> es => MVar a -> Eff es a readMVar = unsafeEff_ . M.readMVar --- | Lifted 'M.swapMVar' that evaluates the new value to WHNF. +-- | Lifted 'M.swapMVar'. swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a -swapMVar var a = unsafeEff_ $ a `seq` M.swapMVar var a +swapMVar var = unsafeEff_ . M.swapMVar var -- | Lifted 'M.tryTakeMVar'. tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) tryTakeMVar = unsafeEff_ . M.tryTakeMVar --- | Lifted 'M.tryPutMVar' that evaluates the new value to WHNF. +-- | Lifted 'M.tryPutMVar'. tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool -tryPutMVar var a = unsafeEff_ $ a `seq` M.tryPutMVar var a - --- | Lifted 'M.isEmptyMVar'. -isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool -isEmptyMVar = unsafeEff_ . M.isEmptyMVar +tryPutMVar var = unsafeEff_ . M.tryPutMVar var -- | Lifted 'M.tryReadMVar'. tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) tryReadMVar = unsafeEff_ . M.tryReadMVar +-- | Lifted 'M.isEmptyMVar'. +isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool +isEmptyMVar = unsafeEff_ . M.isEmptyMVar + -- | Lifted 'M.withMVar'. withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVar var $ unlift . f +{-# INLINE withMVar #-} -- | Lifted 'M.withMVarMasked'. withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do M.withMVarMasked var $ unlift . f +{-# INLINE withMVarMasked #-} --- | Lifted 'M.modifyMVar_' that evaluates the new value to WHNF. +-- | Lifted 'M.modifyMVar_'. modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVar_ var $ \a0 -> do - a <- unlift $ f a0 - a `seq` pure a + M.modifyMVar_ var $ unlift . f +{-# INLINE modifyMVar_ #-} --- | Lifted 'M.modifyMVar' that evaluates the new value to WHNF. +-- | Lifted 'M.modifyMVar'. modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVar var $ \a0 -> do - (a, b) <- unlift $ f a0 - a `seq` pure (a, b) + M.modifyMVar var $ unlift . f +{-# INLINE modifyMVar #-} --- | Lifted 'M.modifyMVarMasked_' that evaluates the new value to WHNF. +-- | Lifted 'M.modifyMVarMasked_'. modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVarMasked_ var $ \a0 -> do - a <- unlift $ f a0 - a `seq` pure a + M.modifyMVarMasked_ var $ unlift . f +{-# INLINE modifyMVarMasked_ #-} --- | Lifted 'M.modifyMVarMasked' that evaluates the new value to WHNF. +-- | Lifted 'M.modifyMVarMasked'. modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do - M.modifyMVarMasked var $ \a0 -> do - a <- unlift $ f a0 - a `seq` pure a + M.modifyMVarMasked var $ unlift . f +{-# INLINE modifyMVarMasked #-} -- | Lifted 'M.mkWeakMVar'. -mkWeakMVar :: Concurrent :> es => MVar a -> Eff es () -> Eff es (Weak (MVar a)) +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakMVar + :: (HasCallStack, Concurrent :> es) + => MVar a -> Eff es () + -> Eff es (Weak (MVar a)) mkWeakMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. M.mkWeakMVar var . unEff f =<< cloneEnv es diff --git a/src/Effectful/Concurrent/MVar/Strict/Compat.hs b/src/Effectful/Concurrent/MVar/Strict/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Concurrent/MVar/Strict/Compat.hs @@ -0,0 +1,138 @@ +-- | Lifted "Control.Concurrent.MVar" with operations that force values put +-- inside an 'MVar' to WHNF. +module Effectful.Concurrent.MVar.Strict.Compat + {-# DEPRECATED "Use Effectful.Concurrent.MVar.Strict" #-} + ( -- * Effect + Concurrent + + -- ** Handlers + , runConcurrent + + -- * MVar + , MVar + , newEmptyMVar + , newMVar + , takeMVar + , putMVar + , readMVar + , swapMVar + , tryTakeMVar + , tryPutMVar + , isEmptyMVar + , withMVar + , withMVarMasked + , modifyMVar + , modifyMVar_ + , modifyMVarMasked + , modifyMVarMasked_ + , tryReadMVar + , mkWeakMVar + ) where + +import System.Mem.Weak (Weak) +import Control.Exception (evaluate) +import Control.Concurrent.MVar (MVar) +import Control.Concurrent.MVar qualified as M + +import Effectful +import Effectful.Concurrent.Effect +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Dispatch.Static.Unsafe + +-- | Lifted 'M.newEmptyMVar'. +newEmptyMVar :: Concurrent :> es => Eff es (MVar a) +newEmptyMVar = unsafeEff_ M.newEmptyMVar + +-- | Lifted 'M.newMVar' that evaluates the value to WHNF. +newMVar :: Concurrent :> es => a -> Eff es (MVar a) +newMVar a = unsafeEff_ $ M.newMVar =<< evaluate a + +-- | Lifted 'M.takeMVar'. +takeMVar :: Concurrent :> es => MVar a -> Eff es a +takeMVar = unsafeEff_ . M.takeMVar + +-- | Lifted 'M.putMVar'. +putMVar :: Concurrent :> es => MVar a -> a -> Eff es () +putMVar var a = unsafeEff_ $ M.putMVar var =<< evaluate a + +-- | Lifted 'M.readMVar'. +readMVar :: Concurrent :> es => MVar a -> Eff es a +readMVar = unsafeEff_ . M.readMVar + +-- | Lifted 'M.swapMVar' that evaluates the new value to WHNF. +swapMVar :: Concurrent :> es => MVar a -> a -> Eff es a +swapMVar var a = unsafeEff_ $ M.swapMVar var =<< evaluate a + +-- | Lifted 'M.tryTakeMVar'. +tryTakeMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) +tryTakeMVar = unsafeEff_ . M.tryTakeMVar + +-- | Lifted 'M.tryPutMVar' that evaluates the new value to WHNF. +tryPutMVar :: Concurrent :> es => MVar a -> a -> Eff es Bool +tryPutMVar var a = unsafeEff_ $ M.tryPutMVar var =<< evaluate a + +-- | Lifted 'M.isEmptyMVar'. +isEmptyMVar :: Concurrent :> es => MVar a -> Eff es Bool +isEmptyMVar = unsafeEff_ . M.isEmptyMVar + +-- | Lifted 'M.tryReadMVar'. +tryReadMVar :: Concurrent :> es => MVar a -> Eff es (Maybe a) +tryReadMVar = unsafeEff_ . M.tryReadMVar + +-- | Lifted 'M.withMVar'. +withMVar :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b +withMVar var f = reallyUnsafeUnliftIO $ \unlift -> do + M.withMVar var $ unlift . f +{-# INLINE withMVar #-} + +-- | Lifted 'M.withMVarMasked'. +withMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es b) -> Eff es b +withMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do + M.withMVarMasked var $ unlift . f +{-# INLINE withMVarMasked #-} + +-- | Lifted 'M.modifyMVar_' that evaluates the new value to WHNF. +modifyMVar_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () +modifyMVar_ var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar_ var $ \a0 -> do + a <- unlift $ f a0 + evaluate a +{-# INLINE modifyMVar_ #-} + +-- | Lifted 'M.modifyMVar' that evaluates the new value to WHNF. +modifyMVar :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b +modifyMVar var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVar var $ \a0 -> do + (a, b) <- unlift $ f a0 + (, b) <$> evaluate a +{-# INLINE modifyMVar #-} + +-- | Lifted 'M.modifyMVarMasked_' that evaluates the new value to WHNF. +modifyMVarMasked_ :: Concurrent :> es => MVar a -> (a -> Eff es a) -> Eff es () +modifyMVarMasked_ var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVarMasked_ var $ \a0 -> do + a <- unlift $ f a0 + evaluate a +{-# INLINE modifyMVarMasked_ #-} + +-- | Lifted 'M.modifyMVarMasked' that evaluates the new value to WHNF. +modifyMVarMasked :: Concurrent :> es => MVar a -> (a -> Eff es (a, b)) -> Eff es b +modifyMVarMasked var f = reallyUnsafeUnliftIO $ \unlift -> do + M.modifyMVarMasked var $ \a0 -> do + (a, b) <- unlift $ f a0 + (, b) <$> evaluate a +{-# INLINE modifyMVarMasked #-} + +-- | Lifted 'M.mkWeakMVar'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakMVar + :: (HasCallStack, Concurrent :> es) + => MVar a + -> Eff es () + -> Eff es (Weak (MVar a)) +mkWeakMVar var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + M.mkWeakMVar var . unEff f =<< cloneEnv es diff --git a/src/Effectful/Concurrent/QSem.hs b/src/Effectful/Concurrent/QSem.hs --- a/src/Effectful/Concurrent/QSem.hs +++ b/src/Effectful/Concurrent/QSem.hs @@ -14,7 +14,7 @@ ) where import Control.Concurrent.QSem (QSem) -import qualified Control.Concurrent.QSem as Q +import Control.Concurrent.QSem qualified as Q import Effectful import Effectful.Concurrent.Effect diff --git a/src/Effectful/Concurrent/QSemN.hs b/src/Effectful/Concurrent/QSemN.hs --- a/src/Effectful/Concurrent/QSemN.hs +++ b/src/Effectful/Concurrent/QSemN.hs @@ -14,7 +14,7 @@ ) where import Control.Concurrent.QSemN (QSemN) -import qualified Control.Concurrent.QSemN as Q +import Control.Concurrent.QSemN qualified as Q import Effectful import Effectful.Concurrent.Effect diff --git a/src/Effectful/Concurrent/STM.hs b/src/Effectful/Concurrent/STM.hs --- a/src/Effectful/Concurrent/STM.hs +++ b/src/Effectful/Concurrent/STM.hs @@ -37,6 +37,7 @@ , STM.takeTMVar , STM.putTMVar , STM.readTMVar + , STM.writeTMVar , STM.tryReadTMVar , STM.swapTMVar , STM.tryTakeTMVar @@ -90,7 +91,7 @@ ) where import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue) -import qualified Control.Concurrent.STM as STM +import Control.Concurrent.STM qualified as STM import System.Mem.Weak (Weak) import GHC.Natural (Natural) @@ -116,7 +117,14 @@ registerDelay = unsafeEff_ . STM.registerDelay -- | Lifted 'STM.mkWeakTVar'. -mkWeakTVar :: Concurrent :> es => TVar a -> Eff es () -> Eff es (Weak (TVar a)) +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakTVar + :: (HasCallStack, Concurrent :> es) + => TVar a + -> Eff es () + -> Eff es (Weak (TVar a)) mkWeakTVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. STM.mkWeakTVar var . unEff f =<< cloneEnv es @@ -130,7 +138,14 @@ newEmptyTMVarIO = unsafeEff_ STM.newEmptyTMVarIO -- | Lifted 'STM.mkWeakTMVar'. -mkWeakTMVar :: Concurrent :> es => TMVar a -> Eff es () -> Eff es (Weak (TMVar a)) +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakTMVar + :: (HasCallStack, Concurrent :> es) + => TMVar a + -> Eff es () + -> Eff es (Weak (TMVar a)) mkWeakTMVar var f = unsafeEff $ \es -> do -- The finalizer can run at any point and in any thread. STM.mkWeakTMVar var . unEff f =<< cloneEnv es diff --git a/src/Effectful/Console/ByteString.hs b/src/Effectful/Console/ByteString.hs --- a/src/Effectful/Console/ByteString.hs +++ b/src/Effectful/Console/ByteString.hs @@ -4,9 +4,9 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString (ByteString) --- > import qualified Data.ByteString.Char8 as BS8 +-- > import Data.ByteString.Char8 qualified as BS8 -- > import Effectful.Console.ByteString (Console) --- > import qualified Effectful.Console.ByteString as Console +-- > import Effectful.Console.ByteString qualified as Console -- module Effectful.Console.ByteString ( -- * Effect @@ -32,7 +32,7 @@ ) import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Char8 qualified as BS8 import Effectful import Effectful.Console.Effect diff --git a/src/Effectful/Console/ByteString/Lazy.hs b/src/Effectful/Console/ByteString/Lazy.hs --- a/src/Effectful/Console/ByteString/Lazy.hs +++ b/src/Effectful/Console/ByteString/Lazy.hs @@ -4,9 +4,9 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString.Lazy.Char8 (ByteString) --- > import qualified Data.ByteString.Lazy.Char8 as LBS8 +-- > import Data.ByteString.Lazy.Char8 qualified as LBS8 -- > import Effectful.Console.ByteString.Lazy (Console) --- > import qualified Effectful.Console.ByteString.Lazy as Console +-- > import Effectful.Console.ByteString.Lazy qualified as Console -- module Effectful.Console.ByteString.Lazy ( -- * Effect @@ -30,7 +30,7 @@ ) import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.ByteString.Lazy.Char8 qualified as LBS8 import Effectful import Effectful.Console.Effect diff --git a/src/Effectful/Console/Effect.hs b/src/Effectful/Console/Effect.hs --- a/src/Effectful/Console/Effect.hs +++ b/src/Effectful/Console/Effect.hs @@ -17,5 +17,5 @@ data instance StaticRep Console = Console -- | Run the 'Console' effect. -runConsole :: IOE :> es => Eff (Console : es) a -> Eff es a +runConsole :: (HasCallStack, IOE :> es) => Eff (Console : es) a -> Eff es a runConsole = evalStaticRep Console diff --git a/src/Effectful/Environment.hs b/src/Effectful/Environment.hs --- a/src/Effectful/Environment.hs +++ b/src/Effectful/Environment.hs @@ -20,7 +20,7 @@ , withProgName ) where -import qualified System.Environment as E +import System.Environment qualified as E import Effectful import Effectful.Dispatch.Static @@ -32,7 +32,7 @@ data instance StaticRep Environment = Environment -- | Run the 'Environment' effect. -runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a +runEnvironment :: (HasCallStack, IOE :> es) => Eff (Environment : es) a -> Eff es a runEnvironment = evalStaticRep Environment -- | Lifted 'E.getArgs'. diff --git a/src/Effectful/FileSystem.hs b/src/Effectful/FileSystem.hs --- a/src/Effectful/FileSystem.hs +++ b/src/Effectful/FileSystem.hs @@ -92,7 +92,7 @@ ) where import Data.Time (UTCTime) -import qualified System.Directory as D +import System.Directory qualified as D import Effectful import Effectful.Dispatch.Static diff --git a/src/Effectful/FileSystem/Effect.hs b/src/Effectful/FileSystem/Effect.hs --- a/src/Effectful/FileSystem/Effect.hs +++ b/src/Effectful/FileSystem/Effect.hs @@ -16,5 +16,5 @@ data instance StaticRep FileSystem = FileSystem -- | Run the 'FileSystem' effect. -runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a +runFileSystem :: (HasCallStack, IOE :> es) => Eff (FileSystem : es) a -> Eff es a runFileSystem = evalStaticRep FileSystem diff --git a/src/Effectful/FileSystem/File/OsPath.hs b/src/Effectful/FileSystem/File/OsPath.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/FileSystem/File/OsPath.hs @@ -0,0 +1,150 @@ +-- | Lifted "System.File.OsPath". +module Effectful.FileSystem.File.OsPath + ( -- * Effect + FileSystem + + -- ** Handlers + , runFileSystem + + -- * Files + , IOMode (..) + , Handle + , openBinaryFile + , withFile + , withBinaryFile + , withFile' + , withBinaryFile' + , readFile + , readFile' + , writeFile + , writeFile' + , appendFile + , appendFile' + , openFile + , openExistingFile + , openTempFile + , openBinaryTempFile + , openTempFileWithDefaultPermissions + , openBinaryTempFileWithDefaultPermissions + ) where + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Prelude hiding (appendFile, readFile, writeFile) +import System.File.OsPath qualified as F +import System.IO (Handle, IOMode (..)) +import System.OsPath (OsPath, OsString) + +import Effectful +import Effectful.Dispatch.Static +import Effectful.FileSystem.Effect + +-- | Lifted 'F.openBinaryFile'. +openBinaryFile :: FileSystem :> es => OsPath -> IOMode -> Eff es Handle +openBinaryFile path = unsafeEff_ . F.openBinaryFile path + +-- | Lifted 'F.withFile'. +withFile + :: FileSystem :> es + => OsPath + -> IOMode + -> (Handle -> Eff es a) + -> Eff es a +withFile path mode inner = unsafeSeqUnliftIO $ \unlift -> do + F.withFile path mode $ unlift . inner + +-- | Lifted 'F.withBinaryFile'. +withBinaryFile + :: FileSystem :> es + => OsPath + -> IOMode + -> (Handle -> Eff es a) + -> Eff es a +withBinaryFile path mode inner = unsafeSeqUnliftIO $ \unlift -> do + F.withBinaryFile path mode $ unlift . inner + +-- | Lifted 'F.withFile''. +withFile' + :: FileSystem :> es + => OsPath + -> IOMode + -> (Handle -> Eff es a) + -> Eff es a +withFile' path mode inner = unsafeSeqUnliftIO $ \unlift -> do + F.withFile' path mode $ unlift . inner + +-- | Lifted 'F.withBinaryFile''. +withBinaryFile' + :: FileSystem :> es + => OsPath + -> IOMode + -> (Handle -> Eff es a) + -> Eff es a +withBinaryFile' path mode inner = unsafeSeqUnliftIO $ \unlift -> do + F.withBinaryFile' path mode $ unlift . inner + +-- | Lifted 'F.readFile'. +readFile :: FileSystem :> es => OsPath -> Eff es BSL.ByteString +readFile = unsafeEff_ . F.readFile + +-- | Lifted 'F.readFile''. +readFile' :: FileSystem :> es => OsPath -> Eff es ByteString +readFile' = unsafeEff_ . F.readFile' + +-- | Lifted 'F.writeFile'. +writeFile :: FileSystem :> es => OsPath -> BSL.ByteString -> Eff es () +writeFile path = unsafeEff_ . F.writeFile path + +-- | Lifted 'F.writeFile''. +writeFile' :: FileSystem :> es => OsPath -> ByteString -> Eff es () +writeFile' path = unsafeEff_ . F.writeFile' path + +-- | Lifted 'F.appendFile'. +appendFile :: FileSystem :> es => OsPath -> BSL.ByteString -> Eff es () +appendFile path = unsafeEff_ . F.appendFile path + +-- | Lifted 'F.appendFile''. +appendFile' :: FileSystem :> es => OsPath -> ByteString -> Eff es () +appendFile' path = unsafeEff_ . F.appendFile' path + +-- | Lifted 'F.openFile'. +openFile :: FileSystem :> es => OsPath -> IOMode -> Eff es Handle +openFile path = unsafeEff_ . F.openFile path + +-- | Lifted 'F.openExistingFile'. +openExistingFile :: FileSystem :> es => OsPath -> IOMode -> Eff es Handle +openExistingFile path = unsafeEff_ . F.openExistingFile path + +-- | Lifted 'F.openTempFile'. +openTempFile + :: FileSystem :> es + => OsPath + -> OsString + -> Eff es (OsPath, Handle) +openTempFile dir = unsafeEff_ . F.openTempFile dir + +-- | Lifted 'F.openBinaryTempFile'. +openBinaryTempFile + :: FileSystem :> es + => OsPath + -> OsString + -> Eff es (OsPath, Handle) +openBinaryTempFile dir = unsafeEff_ . F.openBinaryTempFile dir + +-- | Lifted 'F.openTempFileWithDefaultPermissions'. +openTempFileWithDefaultPermissions + :: FileSystem :> es + => OsPath + -> OsString + -> Eff es (OsPath, Handle) +openTempFileWithDefaultPermissions dir = + unsafeEff_ . F.openTempFileWithDefaultPermissions dir + +-- | Lifted 'F.openBinaryTempFileWithDefaultPermissions'. +openBinaryTempFileWithDefaultPermissions + :: FileSystem :> es + => OsPath + -> OsString + -> Eff es (OsPath, Handle) +openBinaryTempFileWithDefaultPermissions dir = + unsafeEff_ . F.openBinaryTempFileWithDefaultPermissions dir diff --git a/src/Effectful/FileSystem/IO.hs b/src/Effectful/FileSystem/IO.hs --- a/src/Effectful/FileSystem/IO.hs +++ b/src/Effectful/FileSystem/IO.hs @@ -39,7 +39,7 @@ ) where import System.IO (Handle, IOMode (..)) -import qualified System.IO as IO +import System.IO qualified as IO import Effectful import Effectful.Dispatch.Static diff --git a/src/Effectful/FileSystem/IO/ByteString.hs b/src/Effectful/FileSystem/IO/ByteString.hs --- a/src/Effectful/FileSystem/IO/ByteString.hs +++ b/src/Effectful/FileSystem/IO/ByteString.hs @@ -5,8 +5,8 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString (ByteString) --- > import qualified Data.ByteString as BS --- > import qualified Effectful.FileSystem.IO.ByteString as EBS +-- > import Data.ByteString qualified as BS +-- > import Effectful.FileSystem.IO.ByteString qualified as EBS -- module Effectful.FileSystem.IO.ByteString #if MIN_VERSION_bytestring(0,11,2) @@ -35,20 +35,18 @@ , hPutStrLn ) where -import Prelude hiding - ( appendFile - , readFile - , writeFile - ) - import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Char8 qualified as BS8 +import Prelude hiding (appendFile, readFile, writeFile) import System.IO (Handle) import Effectful import Effectful.Dispatch.Static import Effectful.FileSystem + +#if MIN_VERSION_bytestring(0,11,2) +import Data.ByteString qualified as BS +#endif ---------------------------------------- -- Introducing and eliminating ByteStrings diff --git a/src/Effectful/FileSystem/IO/ByteString/Builder.hs b/src/Effectful/FileSystem/IO/ByteString/Builder.hs --- a/src/Effectful/FileSystem/IO/ByteString/Builder.hs +++ b/src/Effectful/FileSystem/IO/ByteString/Builder.hs @@ -5,8 +5,8 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString.Builder (Builder) --- > import qualified Data.ByteString.Builder as BSB --- > import qualified Effectful.FileSystem.IO.ByteString.Builder as EBSB +-- > import Data.ByteString.Builder qualified as BSB +-- > import Effectful.FileSystem.IO.ByteString.Builder qualified as EBSB -- module Effectful.FileSystem.IO.ByteString.Builder ( -- * Executing Builders @@ -16,10 +16,9 @@ #endif ) where -import Prelude hiding (writeFile) - import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as BSB +import Data.ByteString.Builder qualified as BSB +import Prelude hiding (writeFile) import System.IO (Handle) import Effectful diff --git a/src/Effectful/FileSystem/IO/ByteString/Lazy.hs b/src/Effectful/FileSystem/IO/ByteString/Lazy.hs --- a/src/Effectful/FileSystem/IO/ByteString/Lazy.hs +++ b/src/Effectful/FileSystem/IO/ByteString/Lazy.hs @@ -3,8 +3,8 @@ -- to avoid name clashes with the functions provided by "Prelude", e.g.: -- -- > import Data.ByteString.Lazy (ByteString) --- > import qualified Data.ByteString.Lazy.Char8 as LBS8 --- > import qualified Effectful.FileSystem.IO.ByteString.Lazy as ELBS +-- > import Data.ByteString.Lazy.Char8 qualified as LBS8 +-- > import Effectful.FileSystem.IO.ByteString.Lazy qualified as ELBS -- module Effectful.FileSystem.IO.ByteString.Lazy ( -- * Files @@ -29,7 +29,7 @@ ) import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.ByteString.Lazy.Char8 qualified as LBS8 import System.IO (Handle) import Effectful diff --git a/src/Effectful/FileSystem/IO/File.hs b/src/Effectful/FileSystem/IO/File.hs --- a/src/Effectful/FileSystem/IO/File.hs +++ b/src/Effectful/FileSystem/IO/File.hs @@ -15,7 +15,7 @@ import Data.ByteString (ByteString) import System.IO (Handle, IOMode (..)) -import qualified UnliftIO.IO.File as U +import UnliftIO.IO.File qualified as U import Effectful import Effectful.Dispatch.Static diff --git a/src/Effectful/FileSystem/OsPath.hs b/src/Effectful/FileSystem/OsPath.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/FileSystem/OsPath.hs @@ -0,0 +1,345 @@ +-- | Lifted "System.Directory.OsPath". +module Effectful.FileSystem.OsPath + ( -- * Effect + FileSystem + + -- ** Handlers + , runFileSystem + + -- * Actions on directories + , createDirectory + , createDirectoryIfMissing + , removeDirectory + , removeDirectoryRecursive + , removePathForcibly + , renameDirectory + , listDirectory + , getDirectoryContents + + -- ** Current working directory + , getCurrentDirectory + , setCurrentDirectory + , withCurrentDirectory + + -- * Pre-defined directories + , getHomeDirectory + , getXdgDirectory + , getXdgDirectoryList + , getAppUserDataDirectory + , getUserDocumentsDirectory + , getTemporaryDirectory + + -- * Actions on files + , removeFile + , renameFile + , renamePath + , copyFile + , copyFileWithMetadata + , getFileSize + , canonicalizePath + , makeAbsolute + , makeRelativeToCurrentDirectory + + -- * Existence tests + , doesPathExist + , doesFileExist + , doesDirectoryExist + , findExecutable + , findExecutables + , findExecutablesInDirectories + , findFile + , findFiles + , findFileWith + , findFilesWith + + -- * Symbolic links + , createFileLink + , createDirectoryLink + , removeDirectoryLink + , pathIsSymbolicLink + , getSymbolicLinkTarget + + -- * Permissions + , getPermissions + , setPermissions + , copyPermissions + + -- * Timestamps + , getAccessTime + , getModificationTime + , setAccessTime + , setModificationTime + + -- * Re-exports + + -- ** Pre-defined directories + , D.XdgDirectory(..) + , D.XdgDirectoryList(..) + + -- ** Existence tests + , D.exeExtension + + -- ** Permissions + , D.Permissions + , D.emptyPermissions + , D.readable + , D.writable + , D.executable + , D.searchable + , D.setOwnerReadable + , D.setOwnerWritable + , D.setOwnerExecutable + , D.setOwnerSearchable + ) where + +import Data.Time (UTCTime) +import System.Directory.OsPath qualified as D +import System.OsPath (OsPath, OsString) + +import Effectful +import Effectful.Dispatch.Static +import Effectful.FileSystem.Effect + +---------------------------------------- +-- Actions on directories + +-- | Lifted 'D.createDirectory'. +createDirectory :: FileSystem :> es => OsPath -> Eff es () +createDirectory = unsafeEff_ . D.createDirectory + +-- | Lifted 'D.createDirectoryIfMissing'. +createDirectoryIfMissing :: FileSystem :> es => Bool -> OsPath -> Eff es () +createDirectoryIfMissing doCreateParents = + unsafeEff_ . D.createDirectoryIfMissing doCreateParents + +-- | Lifted 'D.removeDirectory'. +removeDirectory :: FileSystem :> es => OsPath -> Eff es () +removeDirectory = unsafeEff_ . D.removeDirectory + +-- | Lifted 'D.removeDirectoryRecursive'. +removeDirectoryRecursive :: FileSystem :> es => OsPath -> Eff es () +removeDirectoryRecursive = unsafeEff_ . D.removeDirectoryRecursive + +-- | Lifted 'D.removePathForcibly'. +removePathForcibly :: FileSystem :> es => OsPath -> Eff es () +removePathForcibly = unsafeEff_ . D.removePathForcibly + +-- | Lifted 'D.renameDirectory'. +renameDirectory :: FileSystem :> es => OsPath -> OsPath -> Eff es () +renameDirectory old = unsafeEff_ . D.renameDirectory old + +-- | Lifted 'D.listDirectory'. +listDirectory :: FileSystem :> es => OsPath -> Eff es [OsPath] +listDirectory = unsafeEff_ . D.listDirectory + +-- | Lifted 'D.getDirectoryContents'. +getDirectoryContents :: FileSystem :> es => OsPath -> Eff es [OsPath] +getDirectoryContents = unsafeEff_ . D.getDirectoryContents + +---------------------------------------- +-- Current working directory + +-- | Lifted 'D.getCurrentDirectory'. +getCurrentDirectory :: FileSystem :> es => Eff es OsPath +getCurrentDirectory = unsafeEff_ D.getCurrentDirectory + +-- | Lifted 'D.setCurrentDirectory'. +setCurrentDirectory :: FileSystem :> es => OsPath -> Eff es () +setCurrentDirectory = unsafeEff_ . D.setCurrentDirectory + +-- | Lifted 'D.withCurrentDirectory'. +withCurrentDirectory :: FileSystem :> es => OsPath -> Eff es a -> Eff es a +withCurrentDirectory path = unsafeLiftMapIO (D.withCurrentDirectory path) + +---------------------------------------- +-- Pre-defined directories + +-- | Lifted 'D.getHomeDirectory'. +getHomeDirectory :: FileSystem :> es => Eff es OsPath +getHomeDirectory = unsafeEff_ D.getHomeDirectory + +-- | Lifted 'D.getXdgDirectory'. +getXdgDirectory + :: FileSystem :> es + => D.XdgDirectory + -> OsPath + -> Eff es OsPath +getXdgDirectory xdgDir = unsafeEff_ . D.getXdgDirectory xdgDir + +-- | Lifted 'D.getXdgDirectoryList'. +getXdgDirectoryList + :: FileSystem :> es + => D.XdgDirectoryList + -> Eff es [OsPath] +getXdgDirectoryList = unsafeEff_ . D.getXdgDirectoryList + +-- | Lifted 'D.getAppUserDataDirectory'. +getAppUserDataDirectory :: FileSystem :> es => OsPath -> Eff es OsPath +getAppUserDataDirectory = unsafeEff_ . D.getAppUserDataDirectory + +-- | Lifted 'D.getUserDocumentsDirectory'. +getUserDocumentsDirectory :: FileSystem :> es => Eff es OsPath +getUserDocumentsDirectory = unsafeEff_ D.getUserDocumentsDirectory + +-- | Lifted 'D.getTemporaryDirectory'. +getTemporaryDirectory :: FileSystem :> es => Eff es OsPath +getTemporaryDirectory = unsafeEff_ D.getTemporaryDirectory + +---------------------------------------- +-- Actions on files + +-- | Lifted 'D.removeFile'. +removeFile :: FileSystem :> es => OsPath -> Eff es () +removeFile = unsafeEff_ . D.removeFile + +-- | Lifted 'D.renameFile'. +renameFile :: FileSystem :> es => OsPath -> OsPath -> Eff es () +renameFile old = unsafeEff_ . D.renameFile old + +-- | Lifted 'D.renamePath'. +renamePath :: FileSystem :> es => OsPath -> OsPath -> Eff es () +renamePath old = unsafeEff_ . D.renamePath old + +-- | Lifted 'D.copyFile'. +copyFile :: FileSystem :> es => OsPath -> OsPath -> Eff es () +copyFile src = unsafeEff_ . D.copyFile src + +-- | Lifted 'D.copyFileWithMetadata'. +copyFileWithMetadata :: FileSystem :> es => OsPath -> OsPath -> Eff es () +copyFileWithMetadata src = unsafeEff_ . D.copyFileWithMetadata src + +-- | Lifted 'D.getFileSize'. +getFileSize :: FileSystem :> es => OsPath -> Eff es Integer +getFileSize = unsafeEff_ . D.getFileSize + +-- | Lifted 'D.canonicalizePath'. +canonicalizePath :: FileSystem :> es => OsPath -> Eff es OsPath +canonicalizePath = unsafeEff_ . D.canonicalizePath + +-- | Lifted 'D.makeAbsolute'. +makeAbsolute :: FileSystem :> es => OsPath -> Eff es OsPath +makeAbsolute = unsafeEff_ . D.makeAbsolute + +-- | Lifted 'D.makeRelativeToCurrentDirectory'. +makeRelativeToCurrentDirectory + :: FileSystem :> es + => OsPath + -> Eff es OsPath +makeRelativeToCurrentDirectory = unsafeEff_ . D.makeRelativeToCurrentDirectory + +---------------------------------------- +-- Existence tests + +-- | Lifted 'D.doesPathExist'. +doesPathExist :: FileSystem :> es => OsPath -> Eff es Bool +doesPathExist = unsafeEff_ . D.doesPathExist + +-- | Lifted 'D.doesFileExist'. +doesFileExist :: FileSystem :> es => OsPath -> Eff es Bool +doesFileExist = unsafeEff_ . D.doesFileExist + +-- | Lifted 'D.doesDirectoryExist'. +doesDirectoryExist :: FileSystem :> es => OsPath -> Eff es Bool +doesDirectoryExist = unsafeEff_ . D.doesDirectoryExist + +-- | Lifted 'D.findExecutable'. +findExecutable :: FileSystem :> es => OsString -> Eff es (Maybe OsPath) +findExecutable = unsafeEff_ . D.findExecutable + +-- | Lifted 'D.findExecutables'. +findExecutables :: FileSystem :> es => OsString -> Eff es [OsPath] +findExecutables = unsafeEff_ . D.findExecutables + +-- | Lifted 'D.findExecutablesInDirectories'. +findExecutablesInDirectories + :: FileSystem :> es + => [OsPath] + -> OsString + -> Eff es [OsPath] +findExecutablesInDirectories dirs = + unsafeEff_ . D.findExecutablesInDirectories dirs + +-- | Lifted 'D.findFile'. +findFile :: FileSystem :> es => [OsPath] -> OsString -> Eff es (Maybe OsPath) +findFile dirs = unsafeEff_ . D.findFile dirs + +-- | Lifted 'D.findFiles'. +findFiles :: FileSystem :> es => [OsPath] -> OsString -> Eff es [OsPath] +findFiles dirs = unsafeEff_ . D.findFiles dirs + +-- | Lifted 'D.findFileWith'. +findFileWith + :: FileSystem :> es + => (OsPath -> Eff es Bool) + -> [OsPath] + -> OsString + -> Eff es (Maybe OsPath) +findFileWith p dirs n = unsafeSeqUnliftIO $ \unlift -> do + D.findFileWith (unlift . p) dirs n + +-- | Lifted 'D.findFilesWith'. +findFilesWith + :: FileSystem :> es + => (OsPath -> Eff es Bool) + -> [OsPath] + -> OsString + -> Eff es [OsPath] +findFilesWith p dirs ns = unsafeSeqUnliftIO $ \unlift -> do + D.findFilesWith (unlift . p) dirs ns + +---------------------------------------- +-- Symbolic links + +-- | Lifted 'D.createFileLink'. +createFileLink :: FileSystem :> es => OsPath -> OsPath -> Eff es () +createFileLink target = unsafeEff_ . D.createFileLink target + +-- | Lifted 'D.createDirectoryLink'. +createDirectoryLink :: FileSystem :> es => OsPath -> OsPath -> Eff es () +createDirectoryLink target = unsafeEff_ . D.createDirectoryLink target + +-- | Lifted 'D.removeDirectoryLink'. +removeDirectoryLink :: FileSystem :> es => OsPath -> Eff es () +removeDirectoryLink = unsafeEff_ . D.removeDirectoryLink + +-- | Lifted 'D.pathIsSymbolicLink'. +pathIsSymbolicLink :: FileSystem :> es => OsPath -> Eff es Bool +pathIsSymbolicLink = unsafeEff_ . D.pathIsSymbolicLink + +-- | Lifted 'D.getSymbolicLinkTarget'. +getSymbolicLinkTarget :: FileSystem :> es => OsPath -> Eff es OsPath +getSymbolicLinkTarget = unsafeEff_ . D.getSymbolicLinkTarget + +---------------------------------------- +-- Permissions + +-- | Lifted 'D.getPermissions'. +getPermissions :: FileSystem :> es => OsPath -> Eff es D.Permissions +getPermissions = unsafeEff_ . D.getPermissions + +-- | Lifted 'D.setPermissions'. +setPermissions :: FileSystem :> es => OsPath -> D.Permissions -> Eff es () +setPermissions path = unsafeEff_ . D.setPermissions path + +-- | Lifted 'D.copyPermissions'. +copyPermissions :: FileSystem :> es => OsPath -> OsPath -> Eff es () +copyPermissions src = unsafeEff_ . D.copyPermissions src + +---------------------------------------- +-- Timestamps + +-- | Lifted 'D.getAccessTime'. +getAccessTime :: FileSystem :> es => OsPath -> Eff es UTCTime +getAccessTime = unsafeEff_ . D.getAccessTime + +-- | Lifted 'D.getModificationTime'. +getModificationTime :: FileSystem :> es => OsPath -> Eff es UTCTime +getModificationTime = unsafeEff_ . D.getModificationTime + +-- | Lifted 'D.setAccessTime'. +setAccessTime :: FileSystem :> es => OsPath -> UTCTime -> Eff es () +setAccessTime path = unsafeEff_ . D.setAccessTime path + +-- | Lifted 'D.setModificationTime'. +setModificationTime :: FileSystem :> es => OsPath -> UTCTime -> Eff es () +setModificationTime path = unsafeEff_ . D.setModificationTime path diff --git a/src/Effectful/Prim/IORef.hs b/src/Effectful/Prim/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Prim/IORef.hs @@ -0,0 +1,79 @@ +-- | Lifted "Data.IORef". +-- +-- /Note:/ it requires 'Prim' because @MutVar@ from the @primitive@ library is a +-- generalization of 'IORef'. +-- +-- @since 2.4.0.0 +module Effectful.Prim.IORef + ( -- * Effect + Prim + + -- ** Handlers + , runPrim + + -- * IORef + , IORef + , newIORef + , readIORef + , writeIORef + , modifyIORef + , modifyIORef' + , atomicModifyIORef + , atomicModifyIORef' + , atomicWriteIORef + , mkWeakIORef + ) where + +import Data.IORef (IORef) +import Data.IORef qualified as Ref +import System.Mem.Weak (Weak) + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Prim + +-- | Lifted 'Ref.newIORef'. +newIORef :: Prim :> es => a -> Eff es (IORef a) +newIORef = unsafeEff_ . Ref.newIORef + +-- | Lifted 'Ref.readIORef'. +readIORef :: Prim :> es => IORef a -> Eff es a +readIORef = unsafeEff_ . Ref.readIORef + +-- | Lifted 'Ref.writeIORef'. +writeIORef :: Prim :> es => IORef a -> a -> Eff es () +writeIORef var = unsafeEff_ . Ref.writeIORef var + +-- | Lifted 'Ref.modifyIORef'. +modifyIORef :: Prim :> es => IORef a -> (a -> a) -> Eff es () +modifyIORef var = unsafeEff_ . Ref.modifyIORef var + +-- | Lifted 'Ref.modifyIORef''. +modifyIORef' :: Prim :> es => IORef a -> (a -> a) -> Eff es () +modifyIORef' var = unsafeEff_ . Ref.modifyIORef' var + +-- | Lifted 'Ref.atomicModifyIORef'. +atomicModifyIORef :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b +atomicModifyIORef var = unsafeEff_ . Ref.atomicModifyIORef var + +-- | Lifted 'Ref.atomicModifyIORef''. +atomicModifyIORef' :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b +atomicModifyIORef' var = unsafeEff_ . Ref.atomicModifyIORef' var + +-- | Lifted 'Ref.atomicWriteIORef''. +atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es () +atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var + +-- | Lifted 'Ref.mkWeakIORef'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakIORef + :: (HasCallStack, Prim :> es) + => IORef a + -> Eff es () + -> Eff es (Weak (IORef a)) +mkWeakIORef var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + Ref.mkWeakIORef var . unEff f =<< cloneEnv es diff --git a/src/Effectful/Prim/IORef/Strict.hs b/src/Effectful/Prim/IORef/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Prim/IORef/Strict.hs @@ -0,0 +1,66 @@ +-- | Lifted "Data.IORef.Strict". +-- +-- @since 2.4.0.0 +module Effectful.Prim.IORef.Strict + ( -- * Effect + Prim + + -- ** Handlers + , runPrim + + -- * IORef + , IORef + , newIORef + , readIORef + , writeIORef + , modifyIORef + , atomicModifyIORef + , atomicWriteIORef + , mkWeakIORef + ) where + +import Data.IORef.Strict (IORef) +import Data.IORef.Strict qualified as Ref +import System.Mem.Weak (Weak) + +import Effectful +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Prim + +-- | Lifted 'Ref.newIORef'. +newIORef :: Prim :> es => a -> Eff es (IORef a) +newIORef = unsafeEff_ . Ref.newIORef + +-- | Lifted 'Ref.readIORef'. +readIORef :: Prim :> es => IORef a -> Eff es a +readIORef = unsafeEff_ . Ref.readIORef + +-- | Lifted 'Ref.writeIORef'. +writeIORef :: Prim :> es => IORef a -> a -> Eff es () +writeIORef var = unsafeEff_ . Ref.writeIORef var + +-- | Lifted 'Ref.modifyIORef'. +modifyIORef :: Prim :> es => IORef a -> (a -> a) -> Eff es () +modifyIORef var = unsafeEff_ . Ref.modifyIORef var + +-- | Lifted 'Ref.atomicModifyIORef'. +atomicModifyIORef :: Prim :> es => IORef a -> (a -> (a, b)) -> Eff es b +atomicModifyIORef var = unsafeEff_ . Ref.atomicModifyIORef var + +-- | Lifted 'Ref.atomicWriteIORef'. +atomicWriteIORef :: Prim :> es => IORef a -> a -> Eff es () +atomicWriteIORef var = unsafeEff_ . Ref.atomicWriteIORef var + +-- | Lifted 'Ref.mkWeakIORef'. +-- +-- /Note:/ the finalizer will run a cloned environment, so any changes it makes +-- to thread local data will not be visible outside of it. +mkWeakIORef + :: (HasCallStack, Prim :> es) + => IORef a + -> Eff es () + -> Eff es (Weak (IORef a)) +mkWeakIORef var f = unsafeEff $ \es -> do + -- The finalizer can run at any point and in any thread. + Ref.mkWeakIORef var . unEff f =<< cloneEnv es diff --git a/src/Effectful/Process.hs b/src/Effectful/Process.hs --- a/src/Effectful/Process.hs +++ b/src/Effectful/Process.hs @@ -51,7 +51,7 @@ import System.Exit (ExitCode) import System.IO (Handle) import System.Posix.Internals (FD) -import qualified System.Process as P +import System.Process qualified as P import Effectful import Effectful.Dispatch.Static @@ -62,7 +62,7 @@ type instance DispatchOf Process = Static WithSideEffects data instance StaticRep Process = Process -runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a +runProcess :: (HasCallStack, IOE :> es) => Eff (Process : es) a -> Eff es a runProcess = evalStaticRep Process ---------------------------------------- diff --git a/src/Effectful/Temporary.hs b/src/Effectful/Temporary.hs --- a/src/Effectful/Temporary.hs +++ b/src/Effectful/Temporary.hs @@ -13,7 +13,7 @@ ) where import System.IO -import qualified UnliftIO.Temporary as T +import UnliftIO.Temporary qualified as T import Effectful import Effectful.Dispatch.Static @@ -25,7 +25,7 @@ data instance StaticRep Temporary = Temporary -- | Run the 'Temporary' effect. -runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a +runTemporary :: (HasCallStack, IOE :> es) => Eff (Temporary : es) a -> Eff es a runTemporary = evalStaticRep Temporary -- | Lifted 'T.withSystemTempFile'. diff --git a/src/Effectful/Timeout.hs b/src/Effectful/Timeout.hs --- a/src/Effectful/Timeout.hs +++ b/src/Effectful/Timeout.hs @@ -9,7 +9,7 @@ , timeout ) where -import qualified System.Timeout as T +import System.Timeout qualified as T import Effectful import Effectful.Dispatch.Static @@ -21,7 +21,7 @@ data instance StaticRep Timeout = Timeout -- | Run the 'Timeout' effect. -runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a +runTimeout :: (HasCallStack, IOE :> es) => Eff (Timeout : es) a -> Eff es a runTimeout = evalStaticRep Timeout -- | Lifted 'T.timeout'. diff --git a/tests/AsyncTests.hs b/tests/AsyncTests.hs --- a/tests/AsyncTests.hs +++ b/tests/AsyncTests.hs @@ -2,16 +2,16 @@ import Control.Concurrent (threadDelay) import Control.Monad +import Data.Set qualified as S import Test.Tasty import Test.Tasty.HUnit -import qualified Data.Set as S import Effectful import Effectful.Concurrent.Async import Effectful.Error.Static import Effectful.State.Dynamic -import qualified Utils as U +import Utils qualified as U asyncTests :: TestTree asyncTests = testGroup "Async" diff --git a/tests/ConcurrencyTests.hs b/tests/ConcurrencyTests.hs --- a/tests/ConcurrencyTests.hs +++ b/tests/ConcurrencyTests.hs @@ -2,15 +2,18 @@ import Control.Concurrent (threadDelay) import Control.Monad +import Data.Set qualified as S import Test.Tasty import Test.Tasty.HUnit import UnliftIO -import qualified Data.Set as S import Effectful +import Effectful.Concurrent qualified as E +import Effectful.Concurrent.Async qualified as E +import Effectful.Dispatch.Dynamic import Effectful.Error.Static import Effectful.State.Dynamic -import qualified Utils as U +import Utils qualified as U concurrencyTests :: TestTree concurrencyTests = testGroup "Concurrency" @@ -20,6 +23,10 @@ , testCase "unlifting several times" test_unliftMany , testCase "async with unmask" test_asyncWithUnmask , testCase "pooled workers" test_pooledWorkers + , testCase "using local unlift correctly works" test_correctLocalUnlift + , testCase "using local unlift incorrectly doesn't work" test_wrongLocalUnlift + , testCase "runInBoundThread shares the environment" test_runInBoundThread + , testCase "runInUnboundThread shares the environment" test_runInUnboundThread ] test_localState :: Assertion @@ -119,3 +126,44 @@ where n = 10 threads = 4 + +test_correctLocalUnlift :: Assertion +test_correctLocalUnlift = runEff . E.runConcurrent $ do + x <- runFork . send . RunAsyncCorrect $ pure () + E.wait x + +test_wrongLocalUnlift :: Assertion +test_wrongLocalUnlift = runEff . E.runConcurrent $ do + U.assertThrowsErrorCall "invalid LocalEnv use" $ do + x <- runFork . send . RunAsyncWrong $ pure () + E.wait x + +test_runInBoundThread :: Assertion +test_runInBoundThread = runEff . E.runConcurrent . evalStateLocal @Int 0 $ do + E.runInBoundThread $ put @Int 1 + U.assertEqual "state change visible" 1 =<< get @Int + +test_runInUnboundThread :: Assertion +test_runInUnboundThread = runEff . E.runConcurrent . evalStateLocal @Int 0 $ do + E.runInUnboundThread $ put @Int 1 + U.assertEqual "state change visible" 1 =<< get @Int + +data Fork :: Effect where + RunAsyncCorrect :: m a -> Fork m (E.Async a) + RunAsyncWrong :: m a -> Fork m (E.Async a) +type instance DispatchOf Fork = Dynamic + +runFork :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a +runFork = interpret $ \env -> \case + RunAsyncCorrect action -> do + -- LocalEnv is correctly used in the thread in belongs to, so creation of + -- the unlifting function should succeed. + localUnlift env strategy $ \unlift -> do + E.async $ unlift action + RunAsyncWrong action -> E.async $ do + -- LocalEnv is incorrectly passed to a different thread, so creation of the + -- unlifting function should fail. + localUnlift env strategy $ \unlift -> do + unlift action + where + strategy = ConcUnlift Ephemeral $ Limited 1 diff --git a/tests/EnvTests.hs b/tests/EnvTests.hs --- a/tests/EnvTests.hs +++ b/tests/EnvTests.hs @@ -11,17 +11,24 @@ import Effectful.Dispatch.Static.Primitive import Effectful.Reader.Static import Effectful.Provider +import Effectful.Provider.List import Effectful.State.Static.Local -import qualified Utils as U +import Utils qualified as U envTests :: TestTree envTests = testGroup "Env" [ testCase "tailEnv works" test_tailEnv + , testCase "unconsEnv of a derived environment errors out" test_unconsDerivedEnv , testCase "subsume works" test_subsumeEnv , testCase "inject works" test_injectEnv , testCase "unsafeCoerce doesn't work" test_noUnsafeCoerce , testCase "interpose works" test_interpose , testCase "interpose/provider works" test_interposeProvider + , testCase "provider interposition works" test_providerInterposition + , testCase "provider list interposition works" test_providerListInterposition + , testCase "localSeqLend/localSeqBorrow works" test_lendBorrowSeparate + , testCase "localLendBorrow works" test_lendBorrowCombined + , testCase "lend/borrow combined shares storage" test_lendBorrowForkShares ] test_tailEnv :: Assertion @@ -36,6 +43,14 @@ s0 :: Int s0 = 1337 +-- | 'unconsEnv' is only meant to form a bracket with 'consEnv', so it must +-- reject environments with a non-zero offset instead of deleting an effect +-- different than the requested one. +test_unconsDerivedEnv :: Assertion +test_unconsDerivedEnv = runEff . evalState @Int 0 . evalState @Bool False $ do + U.assertThrowsErrorCall "unconsEnv of a derived environment" $ do + unsafeEff $ \es -> unconsEnv =<< tailEnv es + test_subsumeEnv :: Assertion test_subsumeEnv = runEff $ do s <- execState @Int 0 . subsume @(State Int) $ do @@ -103,8 +118,6 @@ test_noUnsafeCoerce = do r1 <- try @ErrorCall . evaluate $ unsafeCoerce1 @Int 'a' assertBool "unsafeCoerce1" (isLeft r1) - r2 <- try @ErrorCall . evaluate $ unsafeCoerce2 @Int 'a' - assertBool "unsafeCoerce2" (isLeft r2) unsafeCoerce1 :: forall b a. a -> b unsafeCoerce1 a = runPureEff $ do @@ -121,26 +134,6 @@ Box b <- runReader (Box a) $ raise oops pure b -unsafeCoerce2 :: forall b a. a -> b -unsafeCoerce2 a = runPureEff $ do - backupEs <- unsafeEff cloneEnv - -- 'oops' gains access to the effect stack with Reader (Box b) via the - -- unlifting function that escaped its scope. The problem here is that this - -- effect is no longer in scope. - oops <- runReader @(Box b) (Box undefined) $ do - raiseWith SeqUnlift $ \unlift -> do - pure . unlift $ ask @(Box b) - -- If restoreEnv messes up versioning (i.e. restores the version counter from - -- before the above Reader was used), below code will succeed because the - -- Reader (Box a) will have the same version as Reader (Box b). - unsafeEff $ \es -> restoreEnv es backupEs - -- Put Reader (Box a) where the Reader (Box b) was before and attempt to - -- retrieve 'a' coerced to 'b'. It should fail because 'getLocation' in - -- 'Effectful.Internal.Env' checks that version of the reference is the same - -- as version of the effect. - Box b <- runReader (Box a) $ raise oops - pure b - data Box a = Box a ---------------------------------------- @@ -186,16 +179,52 @@ U.assertEqual "b6" 4 b6 U.assertEqual "b7" 8 b7 +test_providerInterposition :: IO () +test_providerInterposition = runEff $ do + runProvider_ @B @Int (\n -> interpret_ $ \case B -> pure n) $ do + b1 <- provideWith_ @B @Int 2 $ send B + U.assertEqual "b1 original" 2 b1 + doubleProviderInput $ do + b2 <- provideWith_ @B @Int 2 $ send B + U.assertEqual "b2 interposed" 4 b2 + b3 <- provideWith_ @B @Int 2 $ send B + U.assertEqual "b3 original" 2 b3 + +-- | Modify the input of a provider and delegate to the original one. +doubleProviderInput :: Provider_ B Int :> es => Eff es a -> Eff es a +doubleProviderInput = interpose @(Provider_ B Int) $ \env -> \case + ProvideWith n action -> passthrough env $ ProvideWith (n * 2) action + +test_providerListInterposition :: IO () +test_providerListInterposition = runEff $ do + runProviderList_ @[B, A] (\(n :: Int) -> runA n . runB) $ do + b1 <- provideListWith_ @[B, A] @Int 2 $ send B + U.assertEqual "b1 original" 2 b1 + doubleInput $ do + b2 <- provideListWith_ @[B, A] @Int 2 $ send B + U.assertEqual "b2 interposed" 4 b2 + b3 <- provideListWith_ @[B, A] @Int 2 $ send B + U.assertEqual "b3 original" 2 b3 + where + -- Delegates manually instead of using passthrough to exercise + -- localSeqLend with effects introduced by an upstream handler. + doubleInput :: ProviderList_ [B, A] Int :> es => Eff es a -> Eff es a + doubleInput = interpose @(ProviderList_ [B, A] Int) $ \env -> \case + ProvideListWith n action -> provideListWith @[B, A] (n * 2) $ do + localSeqUnlift env $ \unlift -> do + localSeqLend @[B, A] env $ \lend -> do + unlift (lend action) + data A :: Effect where A :: A m Int type instance DispatchOf A = Dynamic runA :: Int -> Eff (A : es) a -> Eff es a -runA n = interpret $ \_ -> \case +runA n = interpret_ $ \case A -> pure n doubleA :: A :> es => Eff es a -> Eff es a -doubleA = interpose $ \_ -> \case +doubleA = interpose_ $ \case A -> (+) <$> send A <*> send A data B :: Effect where @@ -203,9 +232,89 @@ type instance DispatchOf B = Dynamic runB :: A :> es => Eff (B : es) a -> Eff es a -runB = interpret $ \_ -> \case +runB = interpret_ $ \case B -> send A doubleB :: B :> es => Eff es a -> Eff es a -doubleB = interpose $ \_ -> \case +doubleB = interpose_ $ \case B -> (+) <$> send B <*> send B + +---------------------------------------- + +test_lendBorrowSeparate :: Assertion +test_lendBorrowSeparate = runEff $ do + runX1 1 2 . evalState @[Int] [3] . runReader () . runReader @[Int] [4] $ do + U.assertEqual "expected result" [1,2,3,4,1,2,3,4] =<< send X + +test_lendBorrowCombined :: Assertion +test_lendBorrowCombined = runEff $ do + runX2 1 2 . evalState @[Int] [3] . runReader () . runReader @[Int] [4] $ do + U.assertEqual "expected result" [1,2,3,4,1,2,3,4] =<< send X + +data X :: Effect where + X :: (State [Int] :> es, Reader [Int] :> es, Reader () :> es) => X (Eff es) [Int] +type instance DispatchOf X = Dynamic + +runX1 :: Int -> Int -> Eff (X : es) a -> Eff es a +runX1 s0 r0 = reinterpret (evalState s0 . evalState () . runReader r0) $ \env -> \case + X -> localSeqUnlift env $ \unlift -> do + localSeqLend @[State Int, Reader Int] env $ \lend -> do + localSeqBorrow @[Reader [Int], State [Int], Reader ()] env $ \borrow -> do + as <- unlift . lend $ do + () <- ask + s <- get @Int + r <- ask @Int + ss <- get @[Int] + rs <- ask @[Int] + pure $ [s, r] ++ ss ++ rs + bs <- borrow $ do + () <- ask + s <- get @Int + r <- ask @Int + ss <- get @[Int] + rs <- ask @[Int] + pure $ [s, r] ++ ss ++ rs + pure $ as ++ bs + +runX2 :: Int -> Int -> Eff (X : es) a -> Eff es a +runX2 s0 r0 = reinterpret (evalState s0 . evalState () . runReader r0) $ \env -> \case + X -> localSeqUnlift env $ \unlift -> do + localLendBorrow + @[State Int, Reader Int] + @[Reader [Int], State [Int], Reader ()] + env SeqUnlift $ \lend borrow -> do + as <- unlift . lend $ do + () <- ask + s <- get @Int + r <- ask @Int + ss <- get @[Int] + rs <- ask @[Int] + pure $ [s, r] ++ ss ++ rs + bs <- borrow $ do + () <- ask + s <- get @Int + r <- ask @Int + ss <- get @[Int] + rs <- ask @[Int] + pure $ [s, r] ++ ss ++ rs + pure $ as ++ bs + +-- | Under 'SeqForkUnlift' state modification done via the borrowing function +-- must also be visible via the lending function (they share the forked +-- storage), but invisible to the handler. +test_lendBorrowForkShares :: Assertion +test_lendBorrowForkShares = runEff . evalState @Int 0 . runY $ do + U.assertEqual "lend sees borrow's write" 1 =<< send Y + U.assertEqual "handler is isolated" 0 =<< get @Int + +data Y :: Effect where + Y :: State Int :> es => Y (Eff es) Int +type instance DispatchOf Y = Dynamic + +runY :: State Int :> es => Eff (Y : es) a -> Eff es a +runY = interpret $ \env Y -> + localLendBorrow @'[State Int] @'[State Int] env SeqForkUnlift $ \lend borrow -> do + -- Write via borrow (runs against the forked clone)... + borrow $ put @Int 1 + -- ...and read it back via lend (against the same forked clone). + localSeqUnlift env $ \unlift -> unlift . lend $ get @Int diff --git a/tests/EnvironmentTests.hs b/tests/EnvironmentTests.hs --- a/tests/EnvironmentTests.hs +++ b/tests/EnvironmentTests.hs @@ -6,7 +6,7 @@ import Effectful import Effectful.Environment -import qualified Utils as U +import Utils qualified as U environmentTests :: TestTree environmentTests = testCaseSteps "Environment" $ \step -> do diff --git a/tests/ErrorTests.hs b/tests/ErrorTests.hs --- a/tests/ErrorTests.hs +++ b/tests/ErrorTests.hs @@ -5,11 +5,14 @@ import Effectful import Effectful.Dispatch.Dynamic +import Effectful.Error.Dynamic qualified as D import Effectful.Error.Static errorTests :: TestTree errorTests = testGroup "Error" [ testCase "different handlers are independent" test_independentHandlers + , testCase "call stack of dynamic throwError doesn't show internal details" test_dynamicThrowErrorCallStack + , testCase "rethrowError attaches the given call stack" test_rethrowError ] test_independentHandlers :: Assertion @@ -21,6 +24,27 @@ "outerThrow" == fst (last $ getCallStack cs) Right _ -> assertFailure "error caught by the wrong (inner) handler" +test_dynamicThrowErrorCallStack :: Assertion +test_dynamicThrowErrorCallStack = do + Left (cs, ()) <- runEff . D.runError @() $ D.throwError () + case getCallStack cs of + [("throwError", _)] -> pure () + _ -> assertFailure $ "invalid call stack: " ++ prettyCallStack cs + +test_rethrowError :: Assertion +test_rethrowError = runEff $ do + result <- runError @Int . runError @String $ do + originalThrow `catchError` \cs (_ :: String) -> rethrowError cs (42 :: Int) + liftIO $ case result of + Left (cs, e) -> do + assertEqual "rethrown error" 42 e + assertBool "stack trace points to the original throw" $ + "originalThrow" == fst (last $ getCallStack cs) + Right _ -> assertFailure "error not rethrown" + where + originalThrow :: (HasCallStack, Error String :> es) => Eff es a + originalThrow = throwError "oops" + ---------------------------------------- -- Helpers @@ -33,5 +57,5 @@ outerThrow = send OuterThrow runOuterThrow :: Error String :> es => Eff (OuterThrow : es) a -> Eff es a -runOuterThrow = interpret $ \_ -> \case +runOuterThrow = interpret_ $ \case OuterThrow -> throwError "outer" diff --git a/tests/ExceptionTests.hs b/tests/ExceptionTests.hs new file mode 100644 --- /dev/null +++ b/tests/ExceptionTests.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +module ExceptionTests (exceptionTests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.Exception +import Effectful.State.Static.Local + +import Utils qualified as U + +exceptionTests :: TestTree +exceptionTests = testGroup "Exception" + [ testCase "cleanup actions run in the correct order" test_cleanupOrder + , testCase "cleanup actions run masked" test_cleanupMasking +#if MIN_VERSION_base(4,21,0) + , testCase "throwing cleanup action doesn't lose the original exception" + test_cleanupKeepsOriginalException +#endif + ] + +test_cleanupOrder :: Assertion +test_cleanupOrder = runEff $ do + checkOrder "bracket (success)" ["acquire", "action", "release"] $ + bracket (record "acquire") (\_ -> record "release") (\_ -> record "action") + checkOrder "bracket (failure)" ["acquire", "action", "release"] $ + bracket (record "acquire") (\_ -> record "release") (\_ -> failingAction) + checkOrder "bracket_ (failure)" ["acquire", "action", "release"] $ + bracket_ (record "acquire") (record "release") failingAction + checkOrder "bracketOnError (success)" ["acquire", "action"] $ + bracketOnError (record "acquire") (\_ -> record "release") (\_ -> record "action") + checkOrder "bracketOnError (failure)" ["acquire", "action", "release"] $ + bracketOnError (record "acquire") (\_ -> record "release") (\_ -> failingAction) + checkOrder "finally (success)" ["action", "release"] $ + record "action" `finally` record "release" + checkOrder "finally (failure)" ["action", "release"] $ + failingAction `finally` record "release" + checkOrder "onException (success)" ["action"] $ + record "action" `onException` record "release" + checkOrder "onException (failure)" ["action", "release"] $ + failingAction `onException` record "release" + where + record :: State [String] :> es => String -> Eff es () + record msg = modify (msg :) + + failingAction :: State [String] :> es => Eff es () + failingAction = record "action" >> throwIO Original + + checkOrder + :: (HasCallStack, IOE :> es) + => String + -> [String] + -> Eff (State [String] : es) a + -> Eff es () + checkOrder name expected action = do + recorded <- execState [] . trySync $ action + U.assertEqual name expected (reverse recorded) + +test_cleanupMasking :: Assertion +test_cleanupMasking = runEff $ do + bracket getMaskingState + (\acquire -> do + release <- getMaskingState + U.assertEqual "acquire is masked" MaskedInterruptible acquire + U.assertEqual "release is masked" MaskedInterruptible release + ) + (\_ -> do + action <- getMaskingState + U.assertEqual "action is unmasked" Unmasked action + ) + +#if MIN_VERSION_base(4,21,0) +test_cleanupKeepsOriginalException :: Assertion +test_cleanupKeepsOriginalException = runEff $ do + check "bracket" $ + bracket (pure ()) (\_ -> failingCleanup) (\_ -> failingAction) + check "bracket_" $ + bracket_ (pure ()) failingCleanup failingAction + check "bracketOnError" $ + bracketOnError (pure ()) (\_ -> failingCleanup) (\_ -> failingAction) + check "finally" $ + failingAction `finally` failingCleanup + check "onException" $ + failingAction `onException` failingCleanup + check "withException" $ + withException failingAction (\Original -> failingCleanup) + where + failingAction, failingCleanup :: Eff es () + failingAction = throwIO Original + failingCleanup = throwIO Cleanup + + check :: (HasCallStack, IOE :> es) => String -> Eff es () -> Eff es () + check name action = trySync action >>= \case + Right () -> U.assertFailure $ name ++ ": no exception was thrown" + Left ex -> do + U.assertBool (name ++ ": exception of the cleanup action propagates") + $ isCleanup ex + U.assertBool (name ++ ": the original exception is preserved") + $ any isOriginal (whileHandling ex) + + -- | Exceptions recorded in the 'WhileHandling' annotations of the given one. + whileHandling :: SomeException -> [SomeException] + whileHandling ex = + [ orig + | WhileHandling orig <- getExceptionAnnotations (someExceptionContext ex) + ] + + isOriginal :: SomeException -> Bool + isOriginal ex = case fromException ex of + Just Original -> True + Nothing -> False + + isCleanup :: SomeException -> Bool + isCleanup ex = case fromException ex of + Just Cleanup -> True + Nothing -> False +#endif + +---------------------------------------- +-- Helpers + +data Original = Original + deriving stock (Eq, Show) +instance Exception Original + +#if MIN_VERSION_base(4,21,0) +data Cleanup = Cleanup + deriving stock (Eq, Show) +instance Exception Cleanup +#endif diff --git a/tests/FileSystemTests.hs b/tests/FileSystemTests.hs new file mode 100644 --- /dev/null +++ b/tests/FileSystemTests.hs @@ -0,0 +1,53 @@ +module FileSystemTests (fileSystemTests) where + +import Data.ByteString.Char8 qualified as BS8 +import System.OsPath (()) +import System.OsPath qualified as OsPath +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.FileSystem.File.OsPath qualified as F +import Effectful.FileSystem.OsPath +import Effectful.Temporary +import Utils qualified as U + +fileSystemTests :: TestTree +fileSystemTests = testGroup "FileSystem" + [ testCase "OsPath directory operations" test_directoryOperations + , testCase "OsPath file operations" test_fileOperations + ] + +test_directoryOperations :: Assertion +test_directoryOperations = runEff . runFileSystem . runTemporary $ do + withSystemTempDirectory "effectful" $ \tmpDirFp -> do + tmpDir <- OsPath.encodeUtf tmpDirFp + subDirName <- OsPath.encodeUtf "subdir" + let subDir = tmpDir subDirName + createDirectory subDir + subDirExists <- doesDirectoryExist subDir + U.assertBool "subdirectory was not created" subDirExists + newDirName <- OsPath.encodeUtf "newdir" + let newDir = tmpDir newDirName + renameDirectory subDir newDir + contents <- listDirectory tmpDir + U.assertEqual "unexpected directory contents" [newDirName] contents + removeDirectory newDir + newDirExists <- doesDirectoryExist newDir + U.assertBool "directory was not removed" (not newDirExists) + +test_fileOperations :: Assertion +test_fileOperations = runEff . runFileSystem . runTemporary $ do + withSystemTempDirectory "effectful" $ \tmpDirFp -> do + tmpDir <- OsPath.encodeUtf tmpDirFp + fileName <- OsPath.encodeUtf "test.txt" + let file = tmpDir fileName + F.writeFile' file (BS8.pack "hello") + F.appendFile' file (BS8.pack " world") + contents <- F.readFile' file + U.assertEqual "unexpected file contents" (BS8.pack "hello world") contents + size <- getFileSize file + U.assertEqual "unexpected file size" 11 size + removeFile file + fileExists <- doesFileExist file + U.assertBool "file was not removed" (not fileExists) diff --git a/tests/InputTests.hs b/tests/InputTests.hs new file mode 100644 --- /dev/null +++ b/tests/InputTests.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module InputTests (inputTests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.State.Static.Local +import Effectful.Input.Dynamic qualified as ID +import Effectful.Input.Static qualified as IS +import Effectful.Input.Static.Action qualified as IA +import Effectful.Labeled.Input qualified as LI +import Utils qualified as U + +inputTests :: TestTree +inputTests = testGroup "Input" + [ testCase "static" test_static + , testCase "static action reruns the action" test_staticAction + , testCase "dynamic (value)" test_dynamicValue + , testCase "dynamic (action) reruns the action" test_dynamicAction + , testCase "labeled inputs are independent" test_labeled + ] + +test_static :: Assertion +test_static = runEff . IS.runInput @Int 42 $ do + U.assertEqual "input" 42 =<< IS.input @Int + U.assertEqual "inputs" 43 =<< IS.inputs @Int (+ 1) + +test_staticAction :: Assertion +test_staticAction = runEff . evalState @Int 0 . IA.runInput nextValue $ do + U.assertEqual "1st input" 1 =<< IA.input @Int + U.assertEqual "2nd input" 2 =<< IA.input @Int + U.assertEqual "inputs" 3 =<< IA.inputs @Int id + +test_dynamicValue :: Assertion +test_dynamicValue = runEff . ID.runInput @Int 42 $ do + U.assertEqual "input" 42 =<< ID.input @Int + U.assertEqual "inputs" 43 =<< ID.inputs @Int (+ 1) + +test_dynamicAction :: Assertion +test_dynamicAction = runEff . evalState @Int 0 . ID.runInputAction nextValue $ do + U.assertEqual "1st input" 1 =<< ID.input @Int + U.assertEqual "2nd input" 2 =<< ID.input @Int + U.assertEqual "inputs" 3 =<< ID.inputs @Int id + +test_labeled :: Assertion +test_labeled = runEff + . evalState @Int 0 + . LI.runInput @"a" @Int 1 + . LI.runInputAction @"b" nextValue + $ do + U.assertEqual "a" 1 =<< LI.input @"a" @Int + U.assertEqual "inputs a" 11 =<< LI.inputs @"a" @Int (+ 10) + U.assertEqual "1st b" 1 =<< LI.input @"b" @Int + U.assertEqual "2nd b" 2 =<< LI.input @"b" @Int + -- "a" is unaffected by reads of "b". + U.assertEqual "a again" 1 =<< LI.input @"a" @Int + +-- | An action that returns consecutive integers, so that re-running it is +-- observable. +nextValue :: State Int :> es => Eff es Int +nextValue = do + modify @Int (+ 1) + get diff --git a/tests/LabeledTests.hs b/tests/LabeledTests.hs new file mode 100644 --- /dev/null +++ b/tests/LabeledTests.hs @@ -0,0 +1,61 @@ +module LabeledTests (labeledTests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Labeled +import Effectful.Reader.Static +import Utils qualified as U + +labeledTests :: TestTree +labeledTests = testGroup "Labeled" + [ testCase "labeled behaves correctly" $ test_labeledBehavior + , testCase "(labeled . send) and (send . Labeled) behave the same" $ test_labeledSend + ] + +test_labeledBehavior :: Assertion +test_labeledBehavior = do + v <- runEff + . runLabeled @"a" (runReader "a") + . runLabeled @"b" (runReader "b") + . runReader "c" + $ action + assertEqual "expected result" "abc" v + where + action + :: ( Labeled "a" (Reader String) :> es + , Labeled "b" (Reader String) :> es + , Reader String :> es + ) + => Eff es String + action = do + a <- labeled @"b" @(Reader String) $ do + labeled @"a" @(Reader String) $ do + ask + b <- labeled @"b" @(Reader String) $ do + ask + c <- ask + pure $ a ++ b ++ c + +test_labeledSend :: Assertion +test_labeledSend = runEff $ do + runX 1 . runLabeled @"x" (runX 2) $ do + v0 <- send X2 + U.assertEqual "expected result" 1 v0 + v1 <- (labeled @"x" @X . send) X2 + U.assertEqual "expected result" 2 v1 + v2 <- (send . Labeled @"x") X2 + U.assertEqual "expected result" 2 v2 + +data X :: Effect where + X1 :: X m Int + X2 :: (X :> es, Labeled "x" X :> es) => X (Eff es) Int + +type instance DispatchOf X = Dynamic + +runX :: Int -> Eff (X : es) a -> Eff es a +runX x = interpret $ \env -> \case + X1 -> pure x + X2 -> localSeqUnlift env $ \unlift -> unlift $ send X1 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -7,12 +7,19 @@ import EnvTests import EnvironmentTests import ErrorTests +import ExceptionTests +import FileSystemTests +import InputTests +import LabeledTests import NonDetTests +import OutputTests import PrimTests import ReaderTests +import ReturnWithTests import StateTests import TimeoutTests import UnliftTests +import Word64MapTests main :: IO () main = defaultMain $ testGroup "effectful" @@ -21,10 +28,17 @@ , envTests , environmentTests , errorTests + , exceptionTests + , fileSystemTests + , inputTests + , labeledTests , nonDetTests + , outputTests , primTests , readerTests + , returnWithTests , stateTests , timeoutTests , unliftTests + , word64MapTests ] diff --git a/tests/NonDetTests.hs b/tests/NonDetTests.hs --- a/tests/NonDetTests.hs +++ b/tests/NonDetTests.hs @@ -1,15 +1,21 @@ module NonDetTests (nonDetTests) where +import Data.IORef.Strict qualified as S +import Data.Primitive.PrimArray import Test.Tasty import Test.Tasty.HUnit import Effectful import Effectful.Dispatch.Dynamic +import Effectful.Dispatch.Static +import Effectful.Dispatch.Static.Primitive +import Effectful.Internal.Env qualified as I +import Effectful.Internal.Utils import Effectful.NonDet import Effectful.Reader.Static import Effectful.State.Dynamic -import qualified Utils as U +import Utils qualified as U nonDetTests :: TestTree nonDetTests = testGroup "NonDet" @@ -19,7 +25,9 @@ [ testCaseSteps "local state" $ test_state evalStateLocal expectedLocalState , testCaseSteps "shared state" $ test_state evalStateShared expectedSharedState ] + , testCaseSteps "local mutable state" $ test_mutState expectedLocalState , testCaseSteps "different handlers are independent" test_independentHandlers + , testCase "stale reference is detected after rollback" test_staleReferenceAfterRollback ] where leftEmpty :: NonDet :> es => Eff es Bool @@ -30,11 +38,11 @@ expectedLocalState :: OnEmptyPolicy -> Int expectedLocalState = \case - OnEmptyKeep -> 3 - OnEmptyRollback -> 2 + OnEmptyKeep -> 7 + OnEmptyRollback -> 0 expectedSharedState :: OnEmptyPolicy -> Int - expectedSharedState _ = 3 + expectedSharedState _ = 7 test_empty :: Eff [NonDet, IOE] Bool @@ -53,13 +61,33 @@ test_state evalState expectedState step = runEff $ do evalState 0 . runNonDetBoth test $ \policy result -> do liftIO . step $ show policy - U.assertEqual "result" (Just ()) (dropLeft result) + U.assertEqual "result" Nothing (dropLeft result) s <- state @Int $ \s -> (s, 0) U.assertEqual "state" (expectedState policy) s where test :: (NonDet :> es, State Int :> es) => Eff es () - test = (modify @Int (+1) >> empty) <|> modify @Int (+2) + test = do + modify @Int (+1) + _<- (modify @Int (+2) >> empty) <|> (modify @Int (+4) >> empty) + modify @Int (+8) +test_mutState + :: (OnEmptyPolicy -> Int) + -> (String -> IO ()) + -> IO () +test_mutState expectedState step = runEff $ do + runMutInt 0 . runNonDetBoth test $ \policy result -> do + liftIO . step $ show policy + s <- stateMutInt $ \s -> (s, 0) + U.assertEqual "result" Nothing (dropLeft result) + U.assertEqual "state" (expectedState policy) s + where + test :: (NonDet :> es, MutInt :> es) => Eff es () + test = do + modifyMutInt (+1) + _<- (modifyMutInt (+2) >> empty) <|> (modifyMutInt (+4) >> empty) + modifyMutInt (+8) + test_independentHandlers :: (String -> IO ()) -> Assertion test_independentHandlers step = runEff $ do runNonDetBoth test $ \policy result -> liftIO $ do @@ -72,9 +100,73 @@ test :: NonDet :> es => Eff es (Either CallStack Bool) test = runOuterEmpty . runNonDet OnEmptyKeep $ outerEmpty <|> pure True +-- | A reference to an effect captured inside a rolled back branch must be +-- detected as out of date even if the storage was grown within the branch, in +-- which case the rollback must not shrink its capacity. +test_staleReferenceAfterRollback :: Assertion +test_staleReferenceAfterRollback = runEff $ do + ref <- liftIO $ S.newIORef Nothing + result <- runNonDet OnEmptyRollback $ + (do stale <- captureStaleReference 16 + capacity <- getStorageCapacity + liftIO $ S.writeIORef ref $ Just (capacity, stale) + emptyEff) + <|> pure True + U.assertEqual "result" (Just True) (dropLeft result) + liftIO (S.readIORef ref) >>= \case + Nothing -> U.assertFailure "stale reference not captured" + Just (capacity, stale) -> do + -- If the rollback shrunk the capacity of the storage, evaluation of the + -- stale reference below would read out of bounds. + U.assertEqual "capacity" capacity =<< getStorageCapacity + U.assertThrowsErrorCall "stale reference detected" $ liftIO stale + +-- | Run a computation under the given number of effect handlers to grow the +-- storage, then capture an unlifted reference to the innermost one. +captureStaleReference :: IOE :> es => Int -> Eff es (IO Int) +captureStaleReference n = evalStateLocal @Int n $ + if n <= 0 + then withEffToIO SeqUnlift $ \unlift -> pure . unlift $ get @Int + else captureStaleReference (n - 1) + +-- | Get the current capacity of the underlying storage of effects. +getStorageCapacity :: Eff es Int +getStorageCapacity = unsafeEff $ \es -> do + I.Storage _ storageData <- S.readIORef es.storage + getSizeofMutablePrimArray storageData.versions + ---------------------------------------- -- Helpers +data MutInt :: Effect +type instance DispatchOf MutInt = Static NoSideEffects +newtype instance StaticRep MutInt = MutInt (S.IORef Int) + +runMutInt :: Int -> Eff (MutInt : es) a -> Eff es a +runMutInt s action = unsafeEff $ \es -> do + ref <- S.newIORef s + inlineBracket + (consEnv (MutInt ref) relinkMutInt es) + unconsEnv + (unEff action) + where + relinkMutInt :: Relinker StaticRep MutInt + relinkMutInt = Relinker $ \_ (MutInt ref0) -> do + ref <- S.newIORef =<< S.readIORef ref0 + pure $ MutInt ref + +stateMutInt :: MutInt :> es => (Int -> (a, Int)) -> Eff es a +stateMutInt f = unsafeEff $ \es -> do + MutInt ref <- getEnv es + (r, s) <- f <$> S.readIORef ref + S.writeIORef ref s + pure r + +modifyMutInt :: MutInt :> es => (Int -> Int) -> Eff es () +modifyMutInt f = stateMutInt $ ((),) . f + +---- + data OuterEmpty :: Effect where OuterEmpty :: OuterEmpty m a @@ -84,7 +176,7 @@ outerEmpty = send OuterEmpty runOuterEmpty :: NonDet :> es => Eff (OuterEmpty : es) a -> Eff es a -runOuterEmpty = interpret $ \_ -> \case +runOuterEmpty = interpret_ $ \case OuterEmpty -> emptyEff ---- diff --git a/tests/OutputTests.hs b/tests/OutputTests.hs new file mode 100644 --- /dev/null +++ b/tests/OutputTests.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module OutputTests (outputTests) where + +import Data.Foldable qualified as F +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.State.Static.Local +import Effectful.Output.Dynamic qualified as OD +import Effectful.Output.Static.Action qualified as OA +import Effectful.Output.Static.Local.Array qualified as OLA +import Effectful.Output.Static.Local.List qualified as OLL +import Effectful.Output.Static.Shared.Array qualified as OSA +import Effectful.Output.Static.Shared.List qualified as OSL +import Effectful.Labeled.Output qualified as LO +import Utils qualified as U + +outputTests :: TestTree +outputTests = testGroup "Output" + [ testCase "static local list" test_localList + , testCase "static local array" test_localArray + , testCase "static shared list" test_sharedList + , testCase "static shared array" test_sharedArray + , testCase "static action" test_action + , testCase "dynamic dispatches to all backends" test_dynamic + , testCase "labeled outputs are independent" test_labeled + ] + +test_localList :: Assertion +test_localList = runEff $ do + (r, xs) <- OLL.runOutput $ do + mapM_ OLL.output values + pure "done" + U.assertEqual "value" "done" r + U.assertEqual "list" values xs + +test_localArray :: Assertion +test_localArray = runEff $ do + (r, arr) <- OLA.runOutput $ do + mapM_ OLA.output values + pure "done" + U.assertEqual "value" "done" r + U.assertEqual "array" values (F.toList arr) + +test_sharedList :: Assertion +test_sharedList = runEff $ do + (r, xs) <- OSL.runOutput $ do + mapM_ OSL.output values + pure "done" + U.assertEqual "value" "done" r + U.assertEqual "list" values xs + +test_sharedArray :: Assertion +test_sharedArray = runEff $ do + (r, arr) <- OSA.runOutput $ do + mapM_ OSA.output values + pure "done" + U.assertEqual "value" "done" r + U.assertEqual "array" values (F.toList arr) + +test_action :: Assertion +test_action = runEff $ do + (_, acc) <- runState @[Int] [] . OA.runOutput @Int (\o -> modify (o :)) $ do + mapM_ OA.output values + U.assertEqual "values fed in order" (reverse values) acc + +test_dynamic :: Assertion +test_dynamic = runEff $ do + (_, la) <- OD.runOutputLocalArray prog + U.assertEqual "local array" values (F.toList la) + (_, ll) <- OD.runOutputLocalList prog + U.assertEqual "local list" values ll + (_, sa) <- OD.runOutputSharedArray prog + U.assertEqual "shared array" values (F.toList sa) + (_, sl) <- OD.runOutputSharedList prog + U.assertEqual "shared list" values sl + (_, acc) <- runState @[Int] [] . OD.runOutputAction @Int (\o -> modify (o :)) $ prog + U.assertEqual "action" (reverse values) acc + where + prog :: (HasCallStack, OD.Output Int :> es) => Eff es () + prog = mapM_ OD.output values + +test_labeled :: Assertion +test_labeled = runEff $ do + ((_, bs), as) <- LO.runOutputLocalList @"a" @Int . LO.runOutputLocalList @"b" @Int $ do + LO.output @"a" @Int 1 + LO.output @"b" @Int 10 + LO.output @"a" @Int 2 + LO.output @"b" @Int 20 + U.assertEqual "label a" [1, 2] as + U.assertEqual "label b" [10, 20] bs + +-- | Emitting more values than the initial (zero) capacity exercises the array +-- growth path in the array backends. +values :: [Int] +values = [1 .. 10] diff --git a/tests/PrimTests.hs b/tests/PrimTests.hs --- a/tests/PrimTests.hs +++ b/tests/PrimTests.hs @@ -3,7 +3,7 @@ import Data.Primitive.MutVar import Test.Tasty import Test.Tasty.HUnit -import qualified Utils as U +import Utils qualified as U import Effectful import Effectful.Prim diff --git a/tests/ReaderTests.hs b/tests/ReaderTests.hs --- a/tests/ReaderTests.hs +++ b/tests/ReaderTests.hs @@ -5,13 +5,14 @@ import Effectful import Effectful.Dispatch.Dynamic -import Effectful.Reader.Dynamic -import qualified Utils as U +import Effectful.Reader.Dynamic qualified as D +import Effectful.Reader.Static qualified as S +import Utils qualified as U readerTests :: TestTree readerTests = testGroup "Reader" - [ testCase "local works in handlers (dynamic/static)" $ test_localInHandler runReader - , testCase "local works in handlers (dynamic/pure)" $ test_localInHandler runPureReader + [ testCase "local works in handlers (static)" test_localInHandlerStatic + , testCase "local works in handlers (dynamic)" test_localInHandlerDynamic ] data SomeEff :: Effect where @@ -19,21 +20,16 @@ type instance DispatchOf SomeEff = Dynamic -test_localInHandler - :: (forall r es a. r -> Eff (Reader r : es) a -> Eff es a) - -> Assertion -test_localInHandler runR = runEff . runR "global" . interpret f $ do - local (const "local") $ send SomeAction +test_localInHandlerStatic :: Assertion +test_localInHandlerStatic = runEff . S.runReader "global" . interpret f $ do + S.local (const "local") $ send SomeAction where - f :: (IOE :> es, Reader String :> es) => EffectHandler SomeEff es - f _ SomeAction = U.assertEqual "expected result" "local" =<< ask + f :: (IOE :> es, S.Reader String :> es) => EffectHandler SomeEff es + f _ SomeAction = U.assertEqual "expected result" "local" =<< S.ask --- | Purely dynamic Reader for testing purposes. -runPureReader :: r -> Eff (Reader r : es) a -> Eff es a -runPureReader r0 = interpret (handler r0) +test_localInHandlerDynamic :: Assertion +test_localInHandlerDynamic = runEff . D.runReader "global" . interpret f $ do + D.local (const "local") $ send SomeAction where - handler :: r -> EffectHandler (Reader r) handlerEs - handler r env = \case - Ask -> pure r - Local f m -> localSeqUnlift env $ \unlift -> do - unlift $ interpose (handler $ f r) m + f :: (IOE :> es, D.Reader String :> es) => EffectHandler SomeEff es + f _ SomeAction = U.assertEqual "expected result" "local" =<< D.ask diff --git a/tests/ReturnWithTests.hs b/tests/ReturnWithTests.hs new file mode 100644 --- /dev/null +++ b/tests/ReturnWithTests.hs @@ -0,0 +1,88 @@ +module ReturnWithTests (returnWithTests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Exception (finally) +import Effectful.Labeled.ReturnWith qualified as LR +import Effectful.ReturnWith.Dynamic qualified as RD +import Effectful.ReturnWith.Static qualified as RS +import Effectful.State.Static.Local +import Utils qualified as U + +returnWithTests :: TestTree +returnWithTests = testGroup "ReturnWith" + [ testCase "static short-circuits" test_static + , testCase "static falls through" test_staticFallThrough + , testCase "different handlers are independent" test_independentHandlers + , testCase "cleanup actions run on early return" test_cleanup + , testCase "dynamic short-circuits" test_dynamic + , testCase "labeled handlers are targeted correctly" test_labeled + ] + +test_static :: Assertion +test_static = runEff . evalState @Int 0 $ do + r <- RS.runReturnWith @String $ do + modify @Int (+1) + _ <- RS.returnWith "early" + modify @Int (+1) + pure "late" + U.assertEqual "result" "early" r + U.assertEqual "state changes before returnWith persist" 1 =<< get @Int + +test_staticFallThrough :: Assertion +test_staticFallThrough = runEff $ do + r <- RS.runReturnWith @String $ pure "done" + U.assertEqual "result" "done" r + +test_independentHandlers :: Assertion +test_independentHandlers = runEff $ do + r <- RS.runReturnWith @String . runOuterReturn $ do + inner <- RS.runReturnWith @String $ do + outerReturn + pure "inner" + pure $ "inner handler caught " ++ inner + U.assertEqual "correct value returned" "outer" r + +test_cleanup :: Assertion +test_cleanup = runEff . evalState @Int 0 $ do + r <- RS.runReturnWith @String $ do + (RS.returnWith "early" >> pure "late") `finally` modify @Int (+1) + U.assertEqual "result" "early" r + U.assertEqual "cleanup ran" 1 =<< get @Int + +test_dynamic :: Assertion +test_dynamic = runEff . evalState @Int 0 $ do + r <- RD.runReturnWith @String $ do + modify @Int (+1) + _ <- RD.returnWith "early" + modify @Int (+1) + pure "late" + U.assertEqual "result" "early" r + U.assertEqual "state changes before returnWith persist" 1 =<< get @Int + +test_labeled :: Assertion +test_labeled = runEff $ do + r <- LR.runReturnWith @"outer" @String $ do + n <- LR.runReturnWith @"inner" @Int $ do + _ <- LR.returnWith @"outer" "outer wins" + pure 0 + pure $ "inner returned " ++ show n + U.assertEqual "value caught by the outer handler" "outer wins" r + +---------------------------------------- +-- Helpers + +data OuterReturn :: Effect where + OuterReturn :: OuterReturn m () + +type instance DispatchOf OuterReturn = Dynamic + +outerReturn :: OuterReturn :> es => Eff es () +outerReturn = send OuterReturn + +runOuterReturn :: RS.ReturnWith String :> es => Eff (OuterReturn : es) a -> Eff es a +runOuterReturn = interpret_ $ \case + OuterReturn -> RS.returnWith "outer" diff --git a/tests/StateTests.hs b/tests/StateTests.hs --- a/tests/StateTests.hs +++ b/tests/StateTests.hs @@ -1,15 +1,22 @@ +-- The deprecated stateM needs to be tested until it's removed. +{-# OPTIONS_GHC -Wno-deprecations #-} module StateTests (stateTests) where +import Control.Exception.Lifted qualified as LE +import Control.Exception.Safe qualified as Safe +import Control.Monad +import Control.Monad.Catch qualified as C +import Data.IORef.Strict qualified as S import Test.Tasty import Test.Tasty.HUnit -import qualified Control.Monad.Catch as E -import qualified Control.Exception.Lifted as LE -import qualified UnliftIO.Exception as UE +import UnliftIO.Exception qualified as UE import Effectful import Effectful.Dispatch.Dynamic +import Effectful.Dispatch.Static +import Effectful.Internal.Env import Effectful.State.Static.Local -import qualified Utils as U +import Utils qualified as U stateTests :: TestTree stateTests = testGroup "State" @@ -34,9 +41,19 @@ test_stateM :: Assertion test_stateM = runEff $ do - (a, b) <- runState "hi" . stateM $ \s -> pure (s, s ++ "!!!") + (a, b) <- runState "hi" $ do + stateM $ \s -> do + effs0 <- getEffectReps + -- Trigger reallocation of the internal array in Storage. + _ <- evalState () $ pure () + effs1 <- getEffectReps + when (effs0 == effs1) $ do + U.assertFailure "Internal array was not reallocated" + pure (s, s ++ "!!!") U.assertEqual "correct a" "hi" a U.assertEqual "correct b" "hi!!!" b + where + getEffectReps = unsafeEff $ \es -> (.effects) . (.data_) <$> S.readIORef es.storage test_deepStack :: Assertion test_deepStack = runEff $ do @@ -52,12 +69,14 @@ test_exceptions :: Assertion test_exceptions = runEff $ do - testTry "exceptions" E.try - testCatch "exceptions" E.catch - testTry "lifted-base" LE.try - testCatch "lifted-base" LE.catch - testTry "unliftio" UE.try - testCatch "unliftio" UE.catch + testTry "exceptions" C.try + testCatch "exceptions" C.catch + testTry "safe-exceptions" Safe.try + testCatch "safe-exceptions" Safe.catch + testTry "lifted-base" LE.try + testCatch "lifted-base" LE.catch + testTry "unliftio" UE.try + testCatch "unliftio" UE.catch where testTry :: String @@ -82,7 +101,7 @@ action :: State Int :> es => Eff es () action = do modify @Int (+1) - _ <- E.throwM U.Ex + _ <- C.throwM U.Ex modify @Int (+2) test_localEffects :: Assertion @@ -117,7 +136,7 @@ runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a runHasInt n = -- reinterpret with redundant local effects - reinterpret (evalState () . evalState n . evalState True) $ \_ -> \case + reinterpret_ (evalState () . evalState n . evalState True) $ \case GetInt -> get PutInt i -> put i diff --git a/tests/TimeoutTests.hs b/tests/TimeoutTests.hs --- a/tests/TimeoutTests.hs +++ b/tests/TimeoutTests.hs @@ -6,7 +6,7 @@ import Effectful import Effectful.Timeout -import qualified Utils as U +import Utils qualified as U timeoutTests :: TestTree timeoutTests = testGroup "Timeout" @@ -16,7 +16,7 @@ test_returnBeforeTimeout :: Assertion test_returnBeforeTimeout = runEff $ do - result <- runTimeout $ timeout 1000 $ return () + result <- runTimeout $ timeout 1000000 $ return () U.assertEqual "return value" (Just ()) result test_timeoutBeforeReturn :: Assertion diff --git a/tests/UnliftTests.hs b/tests/UnliftTests.hs --- a/tests/UnliftTests.hs +++ b/tests/UnliftTests.hs @@ -1,12 +1,16 @@ module UnliftTests (unliftTests) where -import Control.Exception +import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit -import qualified UnliftIO.Async as A +import UnliftIO.Async qualified as A import Effectful -import qualified Utils as U +import Effectful.Concurrent.Async qualified as E +import Effectful.Dispatch.Dynamic +import Effectful.Exception +import Effectful.State.Static.Local +import Utils qualified as U unliftTests :: TestTree unliftTests = testGroup "Unlift" @@ -22,6 +26,9 @@ , testCase "Uses in same thread" test_persistentSameThread , testCase "Uses in multiple threads" test_persistentMultipleThreads ] + , testCase "Unlifting functions work correctly" test_unliftingFunctions + , testCase "Escaped setup of reinterpret" test_escapedReinterpretSetup + , testCase "Escaped setup of impose" test_escapedImposeSetup ] test_threadStrategy :: Assertion @@ -34,32 +41,32 @@ test_seqUnliftInNewThread :: Assertion test_seqUnliftInNewThread = runEff $ do - assertThrowsUnliftError "InvalidUseOfSeqUnlift error" $ do + U.assertThrowsErrorCall "InvalidUseOfSeqUnlift error" $ do withEffToIO SeqUnlift $ \runInIO -> do inThread $ runInIO $ return () test_ephemeralInvalid :: Assertion test_ephemeralInvalid = runEff $ do - assertThrowsUnliftError "InvalidNumberOfUses error" $ do + U.assertThrowsErrorCall "InvalidNumberOfUses error" $ do withEffToIO (ConcUnlift Ephemeral $ Limited 0) $ \_ -> return () test_ephemeralSameThread :: Assertion test_ephemeralSameThread = runEff $ do - assertThrowsUnliftError "ExceededNumberOfUses error" $ do + U.assertThrowsErrorCall "ExceededNumberOfUses error" $ do withEffToIO (ConcUnlift Ephemeral $ Limited 1) $ \runInIO -> inThread $ do runInIO $ return () runInIO $ return () test_ephemeralMultipleThreads :: Assertion test_ephemeralMultipleThreads = runEff $ do - assertThrowsUnliftError "ExceededNumberOfUses error" $ do + U.assertThrowsErrorCall "ExceededNumberOfUses error" $ do withEffToIO (ConcUnlift Ephemeral $ Limited 1) $ \runInIO -> do inThread $ runInIO $ return () inThread $ runInIO $ return () test_persistentInvalid :: Assertion test_persistentInvalid = runEff $ do - assertThrowsUnliftError "InvalidNumberOfThreads error" $ do + U.assertThrowsErrorCall "InvalidNumberOfThreads error" $ do withEffToIO (ConcUnlift Persistent $ Limited 0) $ \_ -> return () test_persistentSameThread :: Assertion @@ -70,18 +77,97 @@ test_persistentMultipleThreads :: Assertion test_persistentMultipleThreads = runEff $ do - assertThrowsUnliftError "ExceededNumberOfThreads error" $ do + U.assertThrowsErrorCall "ExceededNumberOfThreads error" $ do withEffToIO (ConcUnlift Persistent $ Limited 1) $ \runInIO -> do inThread $ runInIO $ return () inThread $ runInIO $ return () +test_unliftingFunctions :: Assertion +test_unliftingFunctions = runEff . E.runConcurrent $ do + testFork "runFork1" runFork1 + testFork "runFork2" runFork2 + testFork "runFork3" runFork3 + testFork "runFork4" runFork4 + where + testFork description runFork = do + a <- runFork . send $ ForkWithUnmask $ \unmask -> do + evalState @Int 0 $ raiseWith SeqUnlift $ \unlift -> do + unlift $ modify @Int (+1) + unmask . unlift $ modify @Int (+2) + unlift $ modify @Int (+4) + unmask . unlift $ modify @Int (+8) + unlift $ U.assertEqual (description ++ ": correct state") 15 =<< get @Int + E.waitCatch a >>= \case + Right () -> pure () + Left err -> U.assertFailure $ description ++ ": " ++ show err + +test_escapedReinterpretSetup :: Assertion +test_escapedReinterpretSetup = runEff $ do + io <- reinterpret_ smuggle (\case E -> pure ()) $ send E + U.assertThrows "EscapedSetup error" escapedSetupError $ liftIO io + +test_escapedImposeSetup :: Assertion +test_escapedImposeSetup = runEff . interpret_ (\case E -> pure ()) $ do + io <- impose_ smuggle (\case E -> pure ()) $ send E + U.assertThrows "EscapedSetup error" escapedSetupError $ liftIO io + -- The escaped computation didn't corrupt the environment. + send E + +-- | Smuggle the computation out of the scope of the setup function. +smuggle :: IOE :> es => Eff es a -> Eff es (IO a) +smuggle m = withEffToIO SeqForkUnlift $ \unlift -> pure (unlift m) + +escapedSetupError :: ErrorCall -> Bool +escapedSetupError e = "cloned environment" `isInfixOf` show e + +data E :: Effect where + E :: E m () +type instance DispatchOf E = Dynamic + +data Fork :: Effect where + ForkWithUnmask :: ((forall a. m a -> m a) -> m r) -> Fork m (A.Async r) +type instance DispatchOf Fork = Dynamic + +-- | Uses 'localUnliftIO' and 'withLiftMapIO'. +runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a +runFork1 = interpret $ \env -> \case + ForkWithUnmask m -> do + withLiftMapIO env $ \liftMap -> do + localUnliftIO env strategy $ \unlift -> do + A.asyncWithUnmask $ \unmask -> unlift $ m $ liftMap unmask + where + strategy = ConcUnlift Ephemeral $ Limited 1 + +-- | Uses 'localLiftUnliftIO'. +runFork2 :: IOE :> es => Eff (Fork : es) a -> Eff es a +runFork2 = interpret $ \env -> \case + ForkWithUnmask m -> do + localLiftUnliftIO env strategy $ \lift unlift -> do + A.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift + where + strategy = ConcUnlift Persistent $ Limited 1 + +-- | Uses 'localLiftUnlift'. +runFork3 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a +runFork3 = interpret $ \env -> \case + ForkWithUnmask m -> do + localLiftUnlift env strategy $ \lift unlift -> do + E.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift + where + strategy = ConcUnlift Persistent $ Limited 1 + +-- | Uses 'localLift' and 'localUnlift'. +runFork4 :: (IOE :> es, E.Concurrent :> es) => Eff (Fork : es) a -> Eff es a +runFork4 = interpret $ \env -> \case + ForkWithUnmask m -> do + localLift env strategy $ \lift -> do + localUnlift env strategy $ \unlift -> do + E.asyncWithUnmask $ \unmask -> unlift $ m $ lift . unmask . unlift + where + strategy = ConcUnlift Persistent $ Limited 1 + ---------------------------------------- -- Helpers - -assertThrowsUnliftError - :: IOE :> es - => String -> Eff es a -> Eff es () -assertThrowsUnliftError err = U.assertThrows err (\ErrorCall{} -> True) inThread :: IO a -> IO a inThread k = A.async k >>= A.wait diff --git a/tests/Utils.hs b/tests/Utils.hs --- a/tests/Utils.hs +++ b/tests/Utils.hs @@ -3,14 +3,15 @@ , assertEqual , assertFailure , assertThrows + , assertThrowsErrorCall , Ex(..) ) where -import Control.Monad.Catch import GHC.Stack -import qualified Test.Tasty.HUnit as T +import Test.Tasty.HUnit qualified as T import Effectful +import Effectful.Exception assertBool :: (HasCallStack, IOE :> es) => String -> Bool -> Eff es () assertBool msg p = liftIO $ T.assertBool msg p @@ -37,5 +38,11 @@ (k >> liftIO (T.assertFailure msg)) pure -data Ex = Ex deriving (Eq, Show) +assertThrowsErrorCall + :: IOE :> es + => String -> Eff es a -> Eff es () +assertThrowsErrorCall err = assertThrows err (\ErrorCall{} -> True) + +data Ex = Ex + deriving stock (Eq, Show) instance Exception Ex diff --git a/tests/Word64MapTests.hs b/tests/Word64MapTests.hs new file mode 100644 --- /dev/null +++ b/tests/Word64MapTests.hs @@ -0,0 +1,95 @@ +module Word64MapTests (word64MapTests) where + +import Data.List qualified as L +import Data.Map.Strict qualified as M +import Data.Word +import System.Random +import Test.Tasty +import Test.Tasty.HUnit + +import Effectful.Internal.Utils.Word64Map qualified as WM + +word64MapTests :: TestTree +word64MapTests = testGroup "Word64Map" + [ testCase "Matches Data.Map over a mix of operations" test_differential + , testCase "Distinguishes keys colliding in the low 32 bits" test_truncation + , testCase "Handles boundary keys" test_boundary + , testCase "updateLookupWithKey returns the original value" test_updateLookup + ] + +-- | Run a large mix of inserts and deletes through both 'WM.Word64Map' and +-- 'M.Map' and check that they agree on the value of every key ever touched. +test_differential :: Assertion +test_differential = do + let poolSize = 5000 :: Word64 + flags = randoms (mkStdGen 1) :: [Bool] + keys = randomRs (0, poolSize - 1) (mkStdGen 2) + ops :: [(Bool, Word64, Int)] + ops = take 200000 (zip3 flags keys [0 ..]) + step (wm, m) (ins, k, v) + | ins = (WM.insert k v wm, M.insert k v m) + | otherwise = (WM.delete k wm, M.delete k m) + (wmFinal, mFinal) = L.foldl' step (WM.empty, M.empty) ops + case [ k | (_, k, _) <- ops, WM.lookup k wmFinal /= M.lookup k mFinal ] of + [] -> pure () + (k : _) -> assertFailure $ + "Word64Map and Data.Map disagree on key " ++ show k ++ ": " + ++ show (WM.lookup k wmFinal) ++ " vs " ++ show (M.lookup k mFinal) + +-- | Run a mix of inserts, updates and deletes through both 'WM.Word64Map' and +-- 'M.Map', where updates and deletes go through 'WM.updateLookupWithKey'. +-- Check that it returns the original value (like its 'Data.IntMap' counterpart +-- and unlike the one from 'Data.Map', which returns the updated value) and +-- that both maps agree on the value of every key ever touched. +test_updateLookup :: Assertion +test_updateLookup = do + let poolSize = 500 :: Word64 + sels = randomRs (0 :: Int, 2) (mkStdGen 3) + keys = randomRs (0, poolSize - 1) (mkStdGen 4) + ops :: [(Int, Word64, Int)] + ops = take 50000 (zip3 sels keys [0 ..]) + step (wm, m, bad) (sel, k, v) = case sel of + 0 -> (WM.insert k v wm, M.insert k v m, bad) + 1 -> let (mv, wm') = WM.updateLookupWithKey (\_ _ -> Nothing) k wm + in (wm', M.delete k m, [k | mv /= M.lookup k m] ++ bad) + _ -> let (mv, wm') = WM.updateLookupWithKey (\_ x -> Just (x + 1)) k wm + in (wm', M.adjust (+ 1) k m, [k | mv /= M.lookup k m] ++ bad) + (wmFinal, mFinal, mismatches) = L.foldl' step (WM.empty, M.empty, []) ops + case mismatches of + [] -> pure () + (k : _) -> assertFailure $ + "updateLookupWithKey returned a wrong value for key " ++ show k + case [ k | (_, k, _) <- ops, WM.lookup k wmFinal /= M.lookup k mFinal ] of + [] -> pure () + (k : _) -> assertFailure $ + "Word64Map and Data.Map disagree on key " ++ show k ++ ": " + ++ show (WM.lookup k wmFinal) ++ " vs " ++ show (M.lookup k mFinal) + +-- | Two keys that are equal in their low 32 bits but differ in the high bits +-- must not collide (the reason for not using @IntMap@, which truncates keys to +-- 'Int' on 32-bit platforms). +test_truncation :: Assertion +test_truncation = do + let a = 0x0000000100000001 :: Word64 + b = 0x0000000200000001 :: Word64 + m = WM.insert b 'b' (WM.insert a 'a' WM.empty) + WM.lookup a m @?= Just 'a' + WM.lookup b m @?= Just 'b' + +-- | Boundary keys, in particular the ones around the sign bit, are handled the +-- same as any other (the keys are compared as unsigned). +test_boundary :: Assertion +test_boundary = do + let ks = [ 0, 1, maxBound, maxBound - 1 + , 0x8000000000000000, 0x7fffffffffffffff + ] :: [Word64] + m = L.foldl' (\acc k -> WM.insert k k acc) WM.empty ks + -- Everything inserted is present with the correct value. + mapM_ (\k -> WM.lookup k m @?= Just k) ks + -- A key that was never inserted is absent. + WM.lookup 12345 m @?= Nothing + -- Deleting one key leaves the others intact. + let removed = 0x8000000000000000 + m' = WM.delete removed m + WM.lookup removed m' @?= Nothing + mapM_ (\k -> WM.lookup k m' @?= Just k) (filter (/= removed) ks)