diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# effectful-2.0.0.0 (2022-08-12) +* Make storage references in the environment immutable. +* Remove `checkSizeEnv` and `forkEnv` from + `Effectful.Dispatch.Static.Primitive`. +* Add internal versioning of effects to prevent leakage of `unsafeCoerce`. +* Make `interpose` and `impose` properly interact with other handlers. + # effectful-1.2.0.0 (2022-07-28) * Change `SuffixOf` to `SharedSuffix` and make it behave as advertised. * Add `raiseWith`. diff --git a/bench/Countdown.hs b/bench/Countdown.hs --- a/bench/Countdown.hs +++ b/bench/Countdown.hs @@ -133,6 +133,50 @@ where runR = E.runReader () +---- + +programEffectfulLocalSt :: EL.State Integer E.:> es => E.Eff es Integer +programEffectfulLocalSt = do + n <- EL.state @Integer $ \s -> (s, s - 1) + if n <= 0 + then pure n + else programEffectfulLocalSt +{-# NOINLINE programEffectfulLocalSt #-} + +countdownEffectfulLocalSt :: Integer -> (Integer, Integer) +countdownEffectfulLocalSt n = E.runPureEff . EL.runState n $ programEffectfulLocalSt + +countdownEffectfulLocalDeepSt :: Integer -> (Integer, Integer) +countdownEffectfulLocalDeepSt n = E.runPureEff + . runR . runR . runR . runR . runR + . EL.runState n + . runR . runR . runR . runR . runR + $ programEffectfulLocalSt + where + runR = E.runReader () + +---- + +programEffectfulLocalStM :: EL.State Integer E.:> es => E.Eff es Integer +programEffectfulLocalStM = do + n <- EL.stateM @Integer $ \s -> pure (s, s - 1) + if n <= 0 + then pure n + else programEffectfulLocalStM +{-# NOINLINE programEffectfulLocalStM #-} + +countdownEffectfulLocalStM :: Integer -> (Integer, Integer) +countdownEffectfulLocalStM n = E.runPureEff . EL.runState n $ programEffectfulLocalStM + +countdownEffectfulLocalDeepStM :: Integer -> (Integer, Integer) +countdownEffectfulLocalDeepStM n = E.runPureEff + . runR . runR . runR . runR . runR + . EL.runState n + . runR . runR . runR . runR . runR + $ programEffectfulLocalStM + where + runR = E.runReader () + ---------------------------------------- -- effectful (mvar) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -31,6 +31,14 @@ [ bench "shallow" $ nf countdownEffectfulLocal n , bench "deep" $ nf countdownEffectfulLocalDeep n ] + , bgroup "effectful (local/static/state)" + [ bench "shallow" $ nf countdownEffectfulLocalSt n + , bench "deep" $ nf countdownEffectfulLocalDeepSt n + ] + , bgroup "effectful (local/static/stateM)" + [ bench "shallow" $ nf countdownEffectfulLocalStM n + , bench "deep" $ nf countdownEffectfulLocalDeepStM n + ] , bgroup "effectful (local/dynamic)" [ bench "shallow" $ nf countdownEffectfulDynLocal n , bench "deep" $ nf countdownEffectfulDynLocalDeep n diff --git a/effectful.cabal b/effectful.cabal --- a/effectful.cabal +++ b/effectful.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 build-type: Simple name: effectful -version: 1.2.0.0 +version: 2.0.0.0 license: BSD-3-Clause license-file: LICENSE category: Control @@ -22,7 +22,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.3 || ==9.4.1 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.1 bug-reports: https://github.com/haskell-effectful/effectful/issues source-repository head @@ -67,7 +67,7 @@ , async >= 2.2.2 , bytestring >= 0.10 , directory >= 1.3.2 - , effectful-core >= 1.2.0.0 && < 1.3.0.0 + , effectful-core >= 2.0.0.0 && < 2.0.1.0 , process >= 1.6.9 , time >= 1.9.2 @@ -153,17 +153,17 @@ if flag(benchmark-foreign-libraries) build-depends: mtl - if impl(ghc < 9.3) + if impl(ghc < 9.5) build-depends: cleff >= 0.3.3.0 - if impl(ghc < 9.3) - build-depends: freer-simple + if impl(ghc < 9.5) + build-depends: freer-simple >= 1.2.1.2 - if impl(ghc < 9.3) - build-depends: fused-effects >= 1.1.0.0 + if impl(ghc < 9.5) + build-depends: fused-effects >= 1.1.2.0 - if impl(ghc < 9.3) - build-depends: polysemy + if impl(ghc < 9.5) + build-depends: polysemy >= 1.7.1.0 build-depends: base , async diff --git a/tests/EnvTests.hs b/tests/EnvTests.hs --- a/tests/EnvTests.hs +++ b/tests/EnvTests.hs @@ -1,45 +1,33 @@ module EnvTests (envTests) where +import Control.Exception +import Data.Either import Test.Tasty import Test.Tasty.HUnit import Effectful -import Effectful.Dispatch.Static -import Effectful.Dispatch.Static.Primitive +import Effectful.Dispatch.Dynamic import Effectful.Reader.Static import Effectful.State.Static.Local import qualified Utils as U envTests :: TestTree envTests = testGroup "Env" - [ testCase "staircase forkEnv" test_staircaseForkEnv - , testCase "tailEnv through forks" test_unforkedTailEnv + [ testCase "tailEnv works" test_tailEnv , testCase "subsume works" test_subsumeEnv , testCase "inject works" test_injectEnv + , testCase "unsafeCoerce doesn't leak" test_noUnsafeCoerce + , testCase "interpose works" test_interpose ] -test_staircaseForkEnv :: Assertion -test_staircaseForkEnv = runEff $ do - unsafeEff $ \es0 -> do - es0f <- forkEnv es0 - (`unEff` es0f) $ evalState s0 $ do - unsafeEff $ \es1 -> do - es1f <- forkEnv es1 - (`unEff` es1f) $ runReader () $ do - U.assertEqual "expected result" s0 =<< get - where - s0 :: Int - s0 = 1337 - -test_unforkedTailEnv :: Assertion -test_unforkedTailEnv = runEff . evalState s0 . runReader () $ do - unsafeEff $ \es0 -> do - es0f <- forkEnv es0 - (`unEff` es0f) $ runReader () $ do - unsafeEff $ \es1 -> do - es1f <- forkEnv es1 - (`unEff` es1f) $ runReader () . raise . raise . raise $ do - U.assertEqual "expected result" s0 =<< get +test_tailEnv :: Assertion +test_tailEnv = runEff . evalState s0 $ do + runReader () $ do + runReader () $ do + raise $ do + runReader () $ do + raise . raise $ do + U.assertEqual "expected result" s0 =<< get where s0 :: Int s0 = 1337 @@ -67,3 +55,54 @@ innerAction = do modify @Int (+4) raise $ modify @Int (+8) + +test_noUnsafeCoerce :: Assertion +test_noUnsafeCoerce = do + r <- try @ErrorCall $ funToInt id + assertBool "unsafeCoerce leaks" (isLeft r) + where + funToInt :: (a -> b) -> IO Int + funToInt f = runEff $ do + oops <- runReader @Int 0 $ do + withEffToIO $ \unlift -> do + pure . unlift $ ask @Int + runReader f $ liftIO oops + +---------------------------------------- + +test_interpose :: IO () +test_interpose = runEff $ do + runA . runB . runReader () $ do + a1 <- send A + b1 <- send B + U.assertEqual "a1 original" 3 a1 + U.assertEqual "b1 original" 3 b1 + doubleA $ do + a2 <- send A + b2 <- send B + U.assertEqual "a2 interposed" 6 a2 + U.assertEqual "b2 interposed" 6 b2 + a3 <- send A + b3 <- send B + U.assertEqual "a3 original" 3 a3 + U.assertEqual "b3 original" 3 b3 + +data A :: Effect where + A :: A m Int +type instance DispatchOf A = Dynamic + +runA :: IOE :> es => Eff (A : es) a -> Eff es a +runA = interpret $ \_ -> \case + A -> pure 3 + +doubleA :: (IOE :> es, A :> es) => Eff es a -> Eff es a +doubleA = interpose $ \_ -> \case + A -> (+) <$> send A <*> send A + +data B :: Effect where + B :: B m Int +type instance DispatchOf B = Dynamic + +runB :: (IOE :> es, A :> es) => Eff (B : es) a -> Eff es a +runB = interpret $ \_ -> \case + B -> send A