diff --git a/cabal.project b/cabal.project index 43d6785..166bc48 100644 --- a/cabal.project +++ b/cabal.project @@ -10,5 +10,13 @@ source-repository-package allow-newer: eff:primitive +source-repository-package + type: git + location: https://github.com/sayo-hs/data-effects + tag: 6568b12d3ef720705b851194d5e588ecf62ee491 + subdir: data-effects-core + subdir: data-effects-th + subdir: data-effects + benchmarks: True tests: True diff --git a/heftia-effects/Example/ShiftReset/Main.hs b/heftia-effects/Example/ShiftReset/Main.hs index 8464e67..664aab2 100644 --- a/heftia-effects/Example/ShiftReset/Main.hs +++ b/heftia-effects/Example/ShiftReset/Main.hs @@ -15,33 +15,27 @@ import Control.Monad.Hefty ( sendN, unkey, (&), - type (!!), - type ($), - type (+), - type (:+:), ) -import Control.Monad.Hefty.Reader (runReader) -import Control.Monad.Hefty.ShiftReset (Shift, ShiftEff (ShiftEff), evalShift, runShift_) +import Control.Monad.Hefty.Reader (runAsk, runLocal, runReader) +import Control.Monad.Hefty.ShiftReset (Shift, ShiftEff (ShiftEff), evalShift) import Control.Monad.Hefty.State (evalState) import Data.Effect.Key (type (#>)) import Data.Effect.Reader (Ask, Local, ask, local) -import Data.Effect.ShiftReset (Shift_, getCC, getCC_) +import Data.Effect.ShiftReset (getCC) import Data.Effect.State (State, get'', modify) import Data.Functor ((<&>)) main :: IO () main = do - putStrLn "[handleReaderThenShift]" - handleReaderThenShift + putStrLn "[interpretAskThenShift]" + interpretAskThenShift putStrLn "" - putStrLn "[handleShiftThenReader]" - handleShiftThenReader + putStrLn "[interpretShiftThenAsk]" + interpretShiftThenAsk {- -===== result ===== - -[handleReaderThenShift] +[interpretAskThenShift] [local scope outer] env = 1 [local scope inner] env = 2 [local scope outer] env = 1 @@ -54,7 +48,7 @@ main = do [local scope inner] env = 2 [local scope outer] env = 1 -[handleShiftThenReader] +[interpretShiftThenAsk] [local scope outer] env = 1 [local scope inner] env = 2 [local scope outer] env = 2 @@ -68,8 +62,8 @@ main = do [local scope outer] env = 32 -} -handleReaderThenShift :: IO () -handleReaderThenShift = +interpretAskThenShift :: IO () +interpretAskThenShift = prog & runReader 1 & runEff @@ -91,19 +85,20 @@ handleReaderThenShift = sendN @1 $ liftIO $ putStrLn $ "[local scope inner] env = " ++ show env' send k -handleShiftThenReader :: IO () -handleShiftThenReader = do +interpretShiftThenAsk :: IO () +interpretShiftThenAsk = do prog - & runShift_ - & runReader 1 + & runLocal + & evalShift + & runAsk 1 & (evalState 0 . unkey) & runEff where prog - :: (r ~ (Ask Int + "counter" #> State Int + IO)) - => Shift_ (Local Int !! r) :+: Local Int !! r $ () + :: (r ~ '[Ask Int, "counter" #> State Int, IO]) + => Eff '[Local Int, Shift () '[] r] r () prog = do - k <- getCC_ + ShiftEff k <- getCC env <- ask @Int liftIO $ putStrLn $ "[local scope outer] env = " ++ show env local @Int (* 2) do diff --git a/heftia-effects/Example/SubJump/Main.hs b/heftia-effects/Example/SubJump/Main.hs new file mode 100644 index 0000000..1751086 --- /dev/null +++ b/heftia-effects/Example/SubJump/Main.hs @@ -0,0 +1,134 @@ +-- SPDX-License-Identifier: MPL-2.0 + +module Main where + +import Control.Effect (type (<:), type (<<:)) +import Control.Effect.Key (SendFOEBy, key) +import Control.Monad.Extra (whenM) +import Control.Monad.Hefty (liftIO, runEff, unkey, (&)) +import Control.Monad.Hefty.Reader (runAsk, runLocal, runReader) +import Control.Monad.Hefty.State (askToGet, evalState, localToState) +import Control.Monad.Hefty.SubJump (SubJump', SubJumpKey, evalSubJump, getCC) +import Control.Monad.IO.Class (MonadIO) +import Data.Effect.Reader (Ask, Local, ask, local) +import Data.Effect.State (State, get'', modify) +import Data.Functor ((<&>)) + +prog + :: ( SendFOEBy SubJumpKey (SubJump' ref) m + , Ask Int <: m + , Local Int <<: m + , SendFOEBy "counter" (State Int) m + , MonadIO m + ) + => m () +prog = do + k <- getCC + env <- ask @Int + liftIO $ putStrLn $ "[local scope outer] env = " ++ show env + local @Int (* 2) do + whenM (get'' @"counter" <&> (< 5)) do + modify (+ 1) & key @"counter" + env' <- ask @Int + liftIO $ putStrLn $ "[local scope inner] env = " ++ show env' + k + +main :: IO () +main = do + putStrLn "[handleAskThenSubJump]" + handleAskThenSubJump + + putStrLn "" + putStrLn "[handleSubJumpThenAsk]" + handleSubJumpThenAsk + + putStrLn "" + putStrLn "[interpretReaderAsState]" + interpretReaderAsState + +{- +[handleAskThenSubJump] +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 + +[handleSubJumpThenAsk] +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 1 + +[interpretReaderAsState] +[local scope outer] env = 1 +[local scope inner] env = 2 +[local scope outer] env = 2 +[local scope inner] env = 4 +[local scope outer] env = 4 +[local scope inner] env = 8 +[local scope outer] env = 8 +[local scope inner] env = 16 +[local scope outer] env = 16 +[local scope inner] env = 32 +[local scope outer] env = 32 +-} +handleAskThenSubJump :: IO () +handleAskThenSubJump = + prog + & runReader @Int 1 + & evalSubJump + & (evalState 0 . unkey @"counter") + & runEff + +{- | +Unlike the example of ShiftReset, interpreting SubJump first or interpreting it later results in the same behavior. +This is because the `getCC` version of SubJump differs from that of ShiftReset in that it returns a "pseudo current continuation." +While `ShiftReset.getCC` returns the real current continuation, +`SubJump.getCC` returns an action that contains only the operation `SubJump.jump` which jumps to the control flow at that point in time. +That is, `SubJump.getCC` can be represented in the following pseudo-code: + +@ +SubJump.getCC = pure $ SubJump.jump (goto label reference to the code line at the point where this SubJump.getCC is called) +@ + +First, `runLocal` modifies all `ask` within the local scope. +In the case of ShiftReset, since `getCC` returns the real current continuation, the modification is also applied to `ask` within the continuation. +However, in this case, the `k` returned by `getCC` only contains `SubJump.jump`, so it is not subject to modification. +-} +handleSubJumpThenAsk :: IO () +handleSubJumpThenAsk = + prog + & runLocal @Int + & evalSubJump + & runAsk @Int 1 + & (evalState 0 . unkey @"counter") + & runEff + +{- | +...In contrast to the above behavior, if you want to change it, you can achieve this by converting the `Local`/`Ask` effects into `State` effects and changing the semantics. +In this case, the semantics of `local` are transformed not to modify `ask` within the scope, but instead to save the current environment state value, +overwrite the state, and restore the saved value after the scope ends (`localToState`). +-} +interpretReaderAsState :: IO () +interpretReaderAsState = + prog + & localToState @Int + & askToGet @Int + & evalSubJump + & evalState @Int 1 + & (evalState 0 . unkey @"counter") + & runEff diff --git a/heftia-effects/heftia-effects.cabal b/heftia-effects/heftia-effects.cabal index 931bdbf..971c9a8 100644 --- a/heftia-effects/heftia-effects.cabal +++ b/heftia-effects/heftia-effects.cabal @@ -78,6 +78,7 @@ library Control.Monad.Hefty.Writer Control.Monad.Hefty.State Control.Monad.Hefty.Except + Control.Monad.Hefty.SubJump Control.Monad.Hefty.ShiftReset Control.Monad.Hefty.NonDet Control.Monad.Hefty.Coroutine @@ -113,6 +114,7 @@ library Data.Effect.Writer, Data.Effect.State, Data.Effect.Except, + Data.Effect.SubJump, Data.Effect.ShiftReset, Data.Effect.NonDet, Data.Effect.Coroutine, @@ -197,6 +199,15 @@ executable Continuation build-depends: heftia-effects, +executable SubJump + import: common-base + + main-is: Main.hs + hs-source-dirs: Example/SubJump + build-depends: + heftia-effects, + extra >= 1.7.14 && < 1.9, + executable ShiftReset import: common-base diff --git a/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs b/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs index b503970..d7c1626 100644 --- a/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs +++ b/heftia-effects/src/Control/Monad/Hefty/Concurrent/Parallel.hs @@ -25,6 +25,7 @@ import Control.Monad.Hefty ( Eff, interpret, interpretH, + liftIO, raiseAllH, transform, type (<<|), @@ -42,7 +43,6 @@ import UnliftIO ( MonadIO, MonadUnliftIO, atomically, - liftIO, mask, newEmptyTMVarIO, putTMVar, diff --git a/heftia-effects/src/Control/Monad/Hefty/ShiftReset.hs b/heftia-effects/src/Control/Monad/Hefty/ShiftReset.hs index 06ce36f..7daaf80 100644 --- a/heftia-effects/src/Control/Monad/Hefty/ShiftReset.hs +++ b/heftia-effects/src/Control/Monad/Hefty/ShiftReset.hs @@ -10,16 +10,11 @@ where import Control.Monad.Hefty ( Eff, - MemberHBy, - interpret, - interpretBy, interpretH, interpretHBy, interpretRecHWith, raiseH, runEff, - send0, - sendH, type (~>), ) import Data.Effect.Key (KeyH (KeyH)) @@ -47,20 +42,7 @@ withShift = runEff . evalShift runShift_ :: forall eh ef. Eff (Shift_ (Eff eh ef) ': eh) ef ~> Eff eh ef runShift_ = interpretRecHWith \(KeyH (Shift_' initiate)) k -> initiate k id +{-# DEPRECATED runShift_ "Use Control.Monad.Hefty.SubJump" #-} runReset :: forall eh ef. Eff (Reset ': eh) ef ~> Eff eh ef runReset = interpretH \(Reset a) -> a - -runShiftF :: Eff '[] (ShiftF (Eff '[] ef ans) ': ef) ans -> Eff '[] ef ans -runShiftF = interpretBy pure \(ShiftF initiate) resume -> initiate resume - -runShiftEff :: (Monad n) => (a -> n ans) -> Eff '[] '[ShiftF (n ans), n] a -> n ans -runShiftEff f = - runEff - . interpretBy (send0 . f) \(ShiftF initiate) resume -> - send0 $ initiate $ runEff . resume - -runShiftAsF - :: (MemberHBy ShiftKey (Shift' ans n) eh) - => Eff eh (ShiftF (n ans) ': ef) ~> Eff eh ef -runShiftAsF = interpret $ sendH . fromShiftF diff --git a/heftia-effects/src/Control/Monad/Hefty/State.hs b/heftia-effects/src/Control/Monad/Hefty/State.hs index 3e9d5e8..05c3a8a 100644 --- a/heftia-effects/src/Control/Monad/Hefty/State.hs +++ b/heftia-effects/src/Control/Monad/Hefty/State.hs @@ -23,6 +23,7 @@ import Control.Monad.Hefty ( interposeStateBy, interpret, interpretBy, + interpretH, interpretRecWith, interpretStateBy, interpretStateRecWith, @@ -31,8 +32,12 @@ import Control.Monad.Hefty ( type (<|), type (~>), ) -import Control.Monad.Hefty.Reader (runAsk) -import Data.Effect.Reader (Ask (Ask), ask) +import Control.Monad.Hefty.Reader ( + Ask (..), + Local (..), + ask, + runAsk, + ) import Data.Effect.State import Data.Functor ((<&>)) import UnliftIO (newIORef, readIORef, writeIORef) @@ -121,3 +126,13 @@ evalStateNaiveRec s0 = Get -> (ask @s >>=) Put s -> \k -> k () & interpose @(Ask s) \Ask -> pure s >>> runAsk @s s0 + +localToState :: forall r eh ef. (State r <| ef) => Eff (Local r ': eh) ef ~> Eff eh ef +localToState = + interpretH \(Local f a) -> do + save <- get @r + put $ f save + a <* put save + +askToGet :: forall r ef eh. (State r <| ef) => Eff eh (Ask r ': ef) ~> Eff eh ef +askToGet = interpret \Ask -> get diff --git a/heftia-effects/src/Control/Monad/Hefty/SubJump.hs b/heftia-effects/src/Control/Monad/Hefty/SubJump.hs new file mode 100644 index 0000000..bcc792d --- /dev/null +++ b/heftia-effects/src/Control/Monad/Hefty/SubJump.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- SPDX-License-Identifier: MPL-2.0 + +{- | +Copyright : (c) 2024 Sayo Koyoneda +License : MPL-2.0 (see the LICENSE file) +Maintainer : ymdfield@outlook.jp +-} +module Control.Monad.Hefty.SubJump ( + module Control.Monad.Hefty.SubJump, + module Data.Effect.SubJump, +) +where + +import Control.Arrow ((>>>)) +import Control.Monad.Hefty (Eff, interpretBy, unkey) +import Data.Effect.SubJump +import Data.Functor.Contravariant qualified as C + +runSubJump :: (a -> Eff '[] ef ans) -> Eff '[] (SubJump (C.Op (Eff '[] ef ans)) ': ef) a -> Eff '[] ef ans +runSubJump k = + unkey >>> interpretBy k \case + SubFork -> \exit -> exit . Left . C.Op $ exit . Right + Jump (C.Op exit) x -> \_ -> exit x + +evalSubJump :: Eff '[] (SubJump (C.Op (Eff '[] ef a)) ': ef) a -> Eff '[] ef a +evalSubJump = runSubJump pure diff --git a/heftia/src/Control/Monad/Hefty/Interpret.hs b/heftia/src/Control/Monad/Hefty/Interpret.hs index e5f45b7..ed1d48f 100644 --- a/heftia/src/Control/Monad/Hefty/Interpret.hs +++ b/heftia/src/Control/Monad/Hefty/Interpret.hs @@ -53,7 +53,8 @@ import Data.Effect.OpenUnion.Internal.HO ( (!!+), type (<<|), ) -import Data.FTCQueue (FTCQueue, ViewL (TOne, (:|)), tviewl, (><)) +import Data.FTCQueue (FTCQueue, ViewL (TOne, (:|)), tsingleton, tviewl, (><)) +import Data.Functor ((<&>)) -- * Running t`Eff` @@ -612,3 +613,11 @@ qApp q' x = case tviewl q' of k :| t -> case k x of Val y -> qApp t y Op u q -> Op u (q >< t) + +interleave :: Eff eh ef a -> Eff eh ef b -> Eff eh ef (a, b) +interleave (Val x) m = (x,) <$> m +interleave m (Val x) = m <&> (,x) +interleave (Op u k) (Op u' k') = do + x <- Op u (tsingleton pure) + y <- Op u' (tsingleton pure) + interleave (qApp k x) (qApp k' y) diff --git a/heftia/src/Data/FTCQueue.hs b/heftia/src/Data/FTCQueue.hs index f0cb6ed..88ba0a8 100644 --- a/heftia/src/Data/FTCQueue.hs +++ b/heftia/src/Data/FTCQueue.hs @@ -29,6 +29,9 @@ module Data.FTCQueue ( tviewl, ) where +import Control.Category (Category ((.)), id) +import Prelude hiding ((.)) + {- | Non-empty tree. Deconstruction operations make it more and more left-leaning -} @@ -36,6 +39,10 @@ data FTCQueue m a b where Leaf :: (a -> m b) -> FTCQueue m a b Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b +instance (Applicative f) => Category (FTCQueue f) where + id = Leaf pure + (.) = flip Node + -- | Build a leaf from a single operation. [O(1)] tsingleton :: (a -> m b) -> FTCQueue m a b tsingleton = Leaf