[add] Sub/Jump effects for continuation.

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

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

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

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
 

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,

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

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

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

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)

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