diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..8cea504 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake -Lv --fallback diff --git a/.gitignore b/.gitignore index f046bae..2d0f838 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ /dist-newstyle /cabal.project.local /stack.yaml +result* +.direnv diff --git a/cabal.project b/cabal.project index b94de9e..8914b4b 100644 --- a/cabal.project +++ b/cabal.project @@ -10,13 +10,13 @@ repository head.hackage.ghc.haskell.org 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d -allow-newer: - primitive-0.7.0.1:base - splitmix-0.0.5:base +-- allow-newer: +-- primitive-0.7.0.1:base, +-- splitmix-0.0.5:base -constraints: - primitive ==0.7.0.1, - QuickCheck ==2.13.2 || ==2.14 +-- constraints: +-- primitive ==0.7.0.1, +-- QuickCheck ==2.13.2 || ==2.14 package * optimization: 2 diff --git a/eff/src/Control/Effect/Coroutine.hs b/eff/src/Control/Effect/Coroutine.hs index 829eaba..fe82e50 100644 --- a/eff/src/Control/Effect/Coroutine.hs +++ b/eff/src/Control/Effect/Coroutine.hs @@ -7,16 +7,16 @@ module Control.Effect.Coroutine import Control.Effect.Base -data Coroutine a b :: Effect where - Yield :: a -> Coroutine a b m b +data Coroutine i o :: Effect where + Yield :: o -> Coroutine i o m i -yield :: Coroutine a b :< effs => a -> Eff effs b +yield :: Coroutine i o :< effs => o -> Eff effs i yield = send . Yield -data Status effs a b c - = Done c - | Yielded a !(b -> Eff (Coroutine a b ': effs) c) +data Status effs i o a + = Done a + | Yielded o !(i -> Eff (Coroutine i o ': effs) a) -runCoroutine :: Eff (Coroutine a b ': effs) c -> Eff effs (Status effs a b c) +runCoroutine :: Eff (Coroutine i o ': effs) a -> Eff effs (Status effs i o a) runCoroutine = handle (pure . Done) \case Yield a -> control0 \k -> pure $! Yielded a k diff --git a/eff/src/Control/Effect/Internal.hs b/eff/src/Control/Effect/Internal.hs index a9ec395..eeb4363 100644 --- a/eff/src/Control/Effect/Internal.hs +++ b/eff/src/Control/Effect/Internal.hs @@ -23,9 +23,9 @@ import Data.IORef import Data.Kind (Constraint, Type) import Data.Type.Coercion (Coercion(..), gcoerceWith) import Data.Type.Equality ((:~:)(..), gcastWith) -import GHC.Exts (Any, Int(..), Int#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, prompt#, control0#) +import GHC.Exts (Any, Int(..), Int#, PromptTag#, RealWorld, RuntimeRep(..), SmallArray#, State#, TYPE, control0#, newPromptTag#, prompt#) import GHC.Types (IO(..)) -import System.IO.Unsafe (unsafeDupablePerformIO) +import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) import Control.Effect.Internal.Debug @@ -268,6 +268,28 @@ captureVM a = gcoerceWith (Coercion.sym $ anyCo @a) $ IO.throwIO $! UnwindControl (coerce a) {-# INLINE captureVM #-} +data PromptTag a = PromptTag# { getPromptTag# :: PromptTag# a } + +-- | The global 'PromptTag#' used for all @eff@ handlers. We don’t use a +-- separate 'PromptTag#' for each handler because we have to implement our own +-- prompt tags, anyway, and there’s no easy way to maintain the type safety +-- benefits of using separate prompt tags. +-- +-- However, using a single, global prompt tag for everything is, in fact, +-- astonishingly unsafe. For one, it has a polymorphic type, even though it’s +-- actually only a single prompt tag—it morally has type +-- @'PromptTag' ('Result' 'Any')@—which means using it effectively involves an +-- implicit 'unsafeCoerce'. What’s more, @eff@’s (incredibly unsafe) internal +-- machinery depends on nothing except its primitives ever actually installing +-- these prompt tags. +-- +-- You do not want to use this. +astonishinglyUnsafeGlobalEffPromptTag :: PromptTag (Result a) +astonishinglyUnsafeGlobalEffPromptTag = unsafePerformIO $ IO \s -> + case newPromptTag# s of + (# s', tag #) -> (# s', PromptTag# tag #) +{-# NOINLINE astonishinglyUnsafeGlobalEffPromptTag #-} + -- | Runs an 'EVM' action with a new prompt installed. The arguments specify -- what happens when control exits the action. promptVM @@ -283,9 +305,10 @@ promptVM promptVM m onReturn onAbort onControl = IO.handle handleUnwind do -- TODO: Explain why it is crucial that the exception handler is installed -- outside of the frame where we replace the registers! - Result _ a <- IO (prompt# (unIO (packIOResult m))) + Result _ a <- IO (prompt# tag# (unIO (packIOResult m))) onReturn a where + tag# = getPromptTag# (astonishinglyUnsafeGlobalEffPromptTag @a) handleUnwind (UnwindAbort pid a) = onAbort pid a handleUnwind (UnwindControl cap) = gcoerceWith (anyCo @a) $ onControl (coerce cap) {-# INLINE promptVM #-} @@ -306,8 +329,9 @@ promptVM_ m rs onCapture = promptVM m onReturn rethrowAbort onCapture where rethrowAbort pid a = IO.throwIO $! UnwindAbort pid a {-# INLINE promptVM_ #-} -controlVM :: ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a) -controlVM f = IO (control0# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where +controlVM :: forall a b. ((a -> EVM b) -> IO (Registers, b)) -> IO (Registers, a) +controlVM f = IO (control0# tag# f#) <&> \(Result rs a) -> (BoxRegisters rs, a) where + tag# = getPromptTag# (astonishinglyUnsafeGlobalEffPromptTag @b) f# k# = unIO (f k <&> \(BoxRegisters rs, a) -> Result rs a) where k a = EVM# \rs -> IO $ k# \s -> (# s, Result rs a #) {-# INLINE controlVM #-} diff --git a/eff/test/Control/EffectSpec.hs b/eff/test/Control/EffectSpec.hs index 5e19c08..2ffa8df 100644 --- a/eff/test/Control/EffectSpec.hs +++ b/eff/test/Control/EffectSpec.hs @@ -2,7 +2,7 @@ module Control.EffectSpec (spec) where import Control.Applicative import Control.Monad -import Data.Foldable +import Data.Bifunctor import Data.Functor import Data.Monoid (Sum(..)) import Test.Hspec @@ -93,14 +93,31 @@ spec = do results `shouldBe` (Sum 6, [(Sum 3, True), (Sum 4, False)]) describe "Coroutine" do - let feed :: forall a b effs c. [b] -> Eff (Coroutine a b ': effs) c -> Eff effs [a] + let feed :: forall i o effs a. [i] -> Eff (Coroutine i o ': effs) a + -> Eff effs ([o], Maybe (i -> Eff (Coroutine i o ': effs) a)) feed as0 m = go as0 =<< runCoroutine m where - go (a:as) (Yielded b k) = (b:) <$> (feed as (k a)) - go [] (Yielded b _) = pure [b] - go _ (Done _) = pure [] + go (a:as) (Yielded b k) = first (b:) <$> feed as (k a) + go [] (Yielded b k) = pure ([b], Just k) + go _ (Done _) = pure ([], Nothing) + + feed_ :: forall i o effs a. [i] -> Eff (Coroutine i o ': effs) a -> Eff effs [o] + feed_ xs m = fst <$> feed xs m it "allows suspending and resuming a computation" do let squares :: Coroutine Integer Integer :< effs => Integer -> Eff effs () squares n = yield (n * n) >>= squares - run (feed @Integer @Integer [1..5] (squares 0)) + run (feed_ @Integer @Integer [1..5] (squares 0)) `shouldBe` [0, 1, 4, 9, 16, 25] + + it "allows resuming a computation with different handlers in scope" do + let squares' :: (Reader Integer :< effs, Coroutine () Integer :< effs) => Eff effs a + squares' = ask @Integer >>= \n -> yield @() (n * n) *> squares' + + (results, maybeK) = run $ runReader @Integer 2 $ + feed @() @Integer [(), (), ()] squares' + results `shouldBe` [4, 4, 4, 4] + case maybeK of + Nothing -> expectationFailure "coroutine ended prematurely" + Just k -> + run (runReader @Integer 5 $ feed_ @() @Integer [(), ()] (k ())) + `shouldBe` [25, 25, 25] diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..89d01d9 --- /dev/null +++ b/flake.lock @@ -0,0 +1,294 @@ +{ + "nodes": { + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1673956053, + "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "locked": { + "lastModified": 1678901627, + "narHash": "sha256-U02riOqrKKzwjsxc/400XnElV+UtPUQWpANPlyazjH0=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "93a2b84fc4b70d9e089d029deacc3583435c2ed6", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "fourmolu-012": { + "flake": false, + "locked": { + "narHash": "sha256-yru8ls67DMM6WSeVU6xDmmwa48I8S9CUv9NBaxSQ29M=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/fourmolu-0.12.0.0/fourmolu-0.12.0.0.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/fourmolu-0.12.0.0/fourmolu-0.12.0.0.tar.gz" + } + }, + "ghc-lib-parser-94": { + "flake": false, + "locked": { + "narHash": "sha256-WElfrJexd0VciSYe0T23s/5pxpOQzKhMn0z5zxa0Ax0=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/ghc-lib-parser-9.4.4.20221225/ghc-lib-parser-9.4.4.20221225.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/ghc-lib-parser-9.4.4.20221225/ghc-lib-parser-9.4.4.20221225.tar.gz" + } + }, + "gitignore": { + "flake": false, + "locked": { + "lastModified": 1660459072, + "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, + "haskell-ghc-exactprint": { + "flake": false, + "locked": { + "lastModified": 1678824759, + "narHash": "sha256-2I+GyVrfevo/vWZqIdXZ+Cg0+cU/755M0GhaSHiiZCQ=", + "owner": "alanz", + "repo": "ghc-exactprint", + "rev": "db5e8ab3817c9ee34e37359d5839e9526e05e448", + "type": "github" + }, + "original": { + "owner": "alanz", + "ref": "ghc-9.6", + "repo": "ghc-exactprint", + "type": "github" + } + }, + "haskell-hie-bios": { + "flake": false, + "locked": { + "lastModified": 1679040151, + "narHash": "sha256-1Y/9wCoR+nMvSrEr0EHnRBCkUuhqWPgPuukNM5zzRT8=", + "owner": "mpickering", + "repo": "hie-bios", + "rev": "af192d4116a382afa1721a6f8d77729f98993082", + "type": "github" + }, + "original": { + "owner": "mpickering", + "repo": "hie-bios", + "type": "github" + } + }, + "haskell-hiedb": { + "flake": false, + "locked": { + "lastModified": 1680249133, + "narHash": "sha256-v6PnDMlrdC56QJ9HwDvVFzHkhVbvivUj1LXMVJ0ZLec=", + "owner": "wz1000", + "repo": "HieDb", + "rev": "dac3ebb37ad33f9c042f59091ee87a4b9a2d63d1", + "type": "github" + }, + "original": { + "owner": "wz1000", + "repo": "HieDb", + "type": "github" + } + }, + "haskell-unix-compat": { + "flake": false, + "locked": { + "lastModified": 1664758053, + "narHash": "sha256-JD/EPdPYEOfS6WqGXOZrdcRUiVkHInSwZT8hn/iQmLs=", + "owner": "jacobstanley", + "repo": "unix-compat", + "rev": "3f6bd688cb56224955e77245a2649ba99ea32fff", + "type": "github" + }, + "original": { + "owner": "jacobstanley", + "repo": "unix-compat", + "rev": "3f6bd688cb56224955e77245a2649ba99ea32fff", + "type": "github" + } + }, + "hlint-35": { + "flake": false, + "locked": { + "narHash": "sha256-qQNUlQQnahUGEO92Lm0RwjTGBGr2Yaw0KRuFRMoc5No=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" + } + }, + "hls": { + "inputs": { + "flake-compat": "flake-compat", + "flake-utils": "flake-utils", + "fourmolu-012": "fourmolu-012", + "ghc-lib-parser-94": "ghc-lib-parser-94", + "gitignore": "gitignore", + "haskell-ghc-exactprint": "haskell-ghc-exactprint", + "haskell-hie-bios": "haskell-hie-bios", + "haskell-hiedb": "haskell-hiedb", + "haskell-unix-compat": "haskell-unix-compat", + "hlint-35": "hlint-35", + "nixpkgs": "nixpkgs", + "ormolu-052": "ormolu-052", + "ptr-poker": "ptr-poker", + "stylish-haskell": "stylish-haskell" + }, + "locked": { + "lastModified": 1686604692, + "narHash": "sha256-Vq9gaynXWo973eg3PLY2hUWBJOj+86j0AfzbMjZieP4=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "a951ad33243cddb708bb24cc426506832dd60dd6", + "type": "github" + }, + "original": { + "owner": "haskell", + "repo": "haskell-language-server", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1680680186, + "narHash": "sha256-DqfuocQeQc4pk/ggLntlcf3AoGmnkCcjjL8geGUxv5I=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "391e94a986322a002a084574ccf2fd73814872b1", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "haskell-updates", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1686582075, + "narHash": "sha256-vtflsfKkHtF8IduxDNtbme4cojiqvlvjp5QNYhvoHXc=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "7e63eed145566cca98158613f3700515b4009ce3", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "ormolu-052": { + "flake": false, + "locked": { + "narHash": "sha256-H7eqId488RBRxcf7flgJefAZmRgFJASJva+Oy7GG4q4=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/ormolu-0.5.2.0/ormolu-0.5.2.0.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/ormolu-0.5.2.0/ormolu-0.5.2.0.tar.gz" + } + }, + "ptr-poker": { + "flake": false, + "locked": { + "narHash": "sha256-ll3wuUjkhTE8Grcs8LfGpdiuyobrSBmwgjqPOTlrPac=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/ptr-poker-0.1.2.8/ptr-poker-0.1.2.8.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/ptr-poker-0.1.2.8/ptr-poker-0.1.2.8.tar.gz" + } + }, + "root": { + "inputs": { + "hls": "hls", + "nixpkgs": "nixpkgs_2", + "utils": "utils" + } + }, + "stylish-haskell": { + "flake": false, + "locked": { + "narHash": "sha256-493M/S38dad82mA04l98xK50WPfue618TIln+7hE7VM=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/stylish-haskell-0.14.4.0/stylish-haskell-0.14.4.0.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/stylish-haskell-0.14.4.0/stylish-haskell-0.14.4.0.tar.gz" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + }, + "utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1685518550, + "narHash": "sha256-o2d0KcvaXzTrPRIo0kOLV0/QXHhDQ5DTi+OxcjO8xqY=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "a1720a10a6cfe8234c0e93907ffe81be440f4cef", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..1664e19 --- /dev/null +++ b/flake.nix @@ -0,0 +1,31 @@ +{ + description = "eff"; + inputs.nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; + inputs.utils.url = "github:numtide/flake-utils"; + inputs.hls.url = "github:haskell/haskell-language-server"; + + outputs = { self, nixpkgs, utils, hls }: utils.lib.eachDefaultSystem (system: let + pkgs = nixpkgs.legacyPackages.${system}; + ghcVersion = "ghc961"; + hspkgs = pkgs.haskell.packages.${ghcVersion}.override { + overrides = hfinal: hprev: { + eff = hfinal.callCabal2nix "eff" ./eff { }; + }; + }; + + hsShell = hspkgs.shellFor { + packages = p: [ p.eff ]; + nativeBuildInputs = [ + hls.packages.${system}.haskell-language-server-96 + pkgs.haskellPackages.hlint + pkgs.haskellPackages.cabal-install + ]; + }; + in { + packages = rec { inherit (hspkgs) eff; default = eff; }; + devShells = rec { eff = hsShell; default = eff; }; + }); + + nixConfig.extra-substituters = [ "https://haskell-language-server.cachix.org" ]; + nixConfig.extra-trusted-public-keys = [ "haskell-language-server.cachix.org-1:juFfHrwkOxqIOZShtC4YC1uT1bBcq2RSvC7OMKx0Nz8=" ]; +} diff --git a/notes/semantics-zoo.md b/notes/semantics-zoo.md index 067abcf..6130f08 100644 --- a/notes/semantics-zoo.md +++ b/notes/semantics-zoo.md @@ -49,7 +49,7 @@ Here are the results: All implementations agree when the `Error` handler is inside the `State` handler, but `eff` disagrees with the other implementations when the reverse is true. When the `State` handler is innermost, `mtl`-family libraries provide so-called “transactional state semantics”, which results in modifications to the state within the scope of a `catch` being discarded if an exception is raised. -The transactional semantics is sometimes useful, so this is sometimes provided as an example of why the `mtl`-family semantics is a feature, not a bug. However, it is really just a specific instance of a more general class of interactions that cause `mtl`-family libraries discard state, and other instances are more difficult to justify. For that reason, my perspective is that this behavior constitutes a bug, and `eff` breaks rank accordingly. +The transactional semantics is sometimes useful, so this is sometimes provided as an example of why the `mtl`-family semantics is a feature, not a bug. However, it is really just a specific instance of a more general class of interactions that cause `mtl`-family libraries to discard state, and other instances are more difficult to justify. For that reason, my perspective is that this behavior constitutes a bug, and `eff` breaks rank accordingly. ## `NonDet` + `Error` @@ -113,7 +113,7 @@ And the results: The results in this case are much more interesting, as there is significantly more disagreement! Let’s go over the different libraries one by one: - * In the case of `list-t`, I think its `MonadError` instance is unfortunately just plain broken, as it makes no attempt to install the `catch` handler on branch of execution other than the first. For that reason, I think its behavior can be mostly disregarded. + * In the case of `list-t`, I think its `MonadError` instance is unfortunately just plain broken, as it makes no attempt to install the `catch` handler on any branch of execution other than the first. For that reason, I think its behavior can be mostly disregarded. * `pipes` does somewhat better, getting at least the “`action1`, `NonDet` inner” case right, but the behavior when the `Error` handler is innermost is frankly mystifying to me. I haven’t investigated what exactly causes that. @@ -173,7 +173,7 @@ To summarize, I think there are really only two justifiable semantics here: `catch` is usually the go-to example of a scoping operator, but the `Writer` effect also includes one in the form of `listen`. Here’s a test case that exercises `listen` in combination with `NonDet`: ```haskell -action :: (NonDet :< es, Writer (Sum Int) :< es) => Eff es ((Sum Int), Bool) +action :: (NonDet :< es, Writer (Sum Int) :< es) => Eff es (Sum Int, Bool) action = listen (add 1 *> (add 2 $> True <|> add 3 $> False)) where add = tell . Sum @Int