data-effects 0.3.0.1 → 0.4.0.0

raw patch · 28 files changed

+1112/−548 lines, 28 filesdep +co-log-coredep +containersdep +unbounded-delaysdep ~basedep ~data-effects-coredep ~data-effects-thPVP ok

version bump matches the API change (PVP)

Dependencies added: co-log-core, containers, unbounded-delays, unliftio

Dependency ranges changed: base, data-effects-core, data-effects-th

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• data-effects.cabal +27/−21
• src/Data/Effect/Accum.hs +6/−10
• src/Data/Effect/CC.hs +39/−0
• src/Data/Effect/Chronicle.hs +0/−27
• src/Data/Effect/Concurrent/Parallel.hs +177/−28
• src/Data/Effect/Concurrent/Timer.hs +73/−25
• src/Data/Effect/Cont.hs +0/−12
• src/Data/Effect/Coroutine.hs +29/−18
• src/Data/Effect/Except.hs +44/−31
• src/Data/Effect/Fail.hs +24/−7
• src/Data/Effect/Fix.hs +13/−7
• src/Data/Effect/Fresh.hs +5/−9
• src/Data/Effect/Input.hs +31/−8
• src/Data/Effect/KVStore.hs +54/−15
• src/Data/Effect/Log.hs +34/−3
• src/Data/Effect/NonDet.hs +103/−23
• src/Data/Effect/Output.hs +24/−7
• src/Data/Effect/Provider.hs +152/−58
• src/Data/Effect/Reader.hs +68/−21
• src/Data/Effect/Resource.hs +0/−56
• src/Data/Effect/Select.hs +4/−6
• src/Data/Effect/Shift.hs +61/−0
• src/Data/Effect/ShiftReset.hs +0/−72
• src/Data/Effect/State.hs +79/−15
• src/Data/Effect/Unlift.hs +29/−19
• src/Data/Effect/Writer.hs +22/−42
• src/Prelude.hs +8/−8

@@ -17,3 +17,9 @@  ## 0.3.0.1 -- 2024-11-03 * Fixed build error for GHC 9.4.1.++## 0.4.0.0 -- 2025-04-16++* Adopt to the new v4 interface.+    * Unified first-order and higher-order effect interfaces.+    * Added a generic `Eff` carrier type.

@@ -1,6 +1,6 @@-cabal-version:      2.4+cabal-version:      3.0 name:               data-effects-version:            0.3.0.1+version:            0.4.0.0  -- A short (one-line) description of the package. synopsis: A basic framework for effect systems based on effects represented by GADTs.@@ -19,11 +19,11 @@ -- The license under which the package is released. license:            MPL-2.0 license-file:       LICENSE-author:             Sayo Koyoneda <ymdfield@outlook.jp>-maintainer:         Sayo Koyoneda <ymdfield@outlook.jp>+author:             Sayo contributors <ymdfield@outlook.jp>+maintainer:         ymdfield <ymdfield@outlook.jp>  -- A copyright notice.-copyright: 2023-2024 Sayo Koyoneda+copyright: 2023-2025 Sayo contributors category: Control, Effect  extra-doc-files:@@ -31,18 +31,20 @@     NOTICE     README.md -tested-with:-    GHC == 9.8.2-    GHC == 9.4.1-    GHC == 9.2.8+tested-with: GHC == {9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.1, 9.12.2} +common warnings+    ghc-options: -Wall -Wredundant-constraints+ source-repository head     type: git     location: https://github.com/sayo-hs/data-effects-    tag: v0.3.0.1+    tag: v0.4.0     subdir: data-effects  library+    import: warnings+     exposed-modules:         Data.Effect.Reader         Data.Effect.Writer@@ -56,15 +58,13 @@         Data.Effect.Output         Data.Effect.Fix         Data.Effect.Fail-        Data.Effect.Cont-        Data.Effect.Chronicle-        Data.Effect.Resource         Data.Effect.Fresh         Data.Effect.Concurrent.Parallel         Data.Effect.Concurrent.Timer         Data.Effect.Unlift         Data.Effect.Provider-        Data.Effect.ShiftReset+        Data.Effect.CC+        Data.Effect.Shift         Data.Effect.KVStore         Data.Effect.Log @@ -72,14 +72,13 @@         Data.Effect,         Data.Effect.TH,         Data.Effect.Tag,-        Data.Effect.Key,-        Data.Effect.Key.TH,         Data.Effect.HFunctor,         Data.Effect.HFunctor.HCont,         Data.Effect.HFunctor.TH,+        Data.Effect.OpenUnion,         Control.Effect,-        Control.Effect.Tag,-        Control.Effect.Key,+        Control.Effect.Interpret,+        Control.Effect.Transform,      -- Modules included in this executable, other than Main.     other-modules:@@ -88,15 +87,20 @@     -- LANGUAGE extensions used by modules in this package.     -- other-extensions:     build-depends:-        base                        >= 4.16.4 && < 4.21,-        data-effects-core           ^>= 0.2,-        data-effects-th             ^>= 0.2,+        base                        >= 4.16.4 && < 4.22,+        data-effects-core           ^>= 0.4,+        data-effects-th             ^>= 0.4,         these                       ^>= 1.2,         data-default                >= 0.7.1 && < 0.9,         text                        >= 2.0 && < 2.2,         lens                        >= 5.2.3 && < 5.4,         time                        >= 1.11.1 && < 1.15,         infinite-list               ^>= 0.1.1,+        unliftio,+        containers,+        co-log-core,+        unbounded-delays ^>= 0.1.1,+        time >= 1.11.1 && < 1.15,      hs-source-dirs:   src     ghc-options:      -Wall@@ -116,6 +120,8 @@         PartialTypeSignatures  test-suite test+    import: warnings+     main-is: Driver.hs     hs-source-dirs: test     build-depends:

@@ -1,20 +1,16 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable -} module Data.Effect.Accum where -data Accum w a where-    Add :: w -> Accum f ()-    Look :: Accum w w+data Accum w :: Effect where+    Add :: w -> Accum w f ()+    Look :: Accum w f w -makeEffectF [''Accum]+makeEffectF ''Accum

@@ -0,0 +1,39 @@+{-# HLINT ignore "Avoid lambda" #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- SPDX-License-Identifier: MPL-2.0++{- |+Copyright   :  (c) 2024-2025 Sayo contributors+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+-}+module Data.Effect.CC (+    module Data.Effect.CC,+    CC (SubFork, Jump),+    callCC_,+    sub,+)+where++import Control.Effect (callCC_, sub)+import Data.Effect (CC (Jump, SubFork))+import Data.Function (fix)++makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''CC++callCC+    :: forall a ref es ff c+     . (CC ref :> es, Monad (Eff ff es), Free c ff)+    => ((forall b. a -> Eff ff es b) -> Eff ff es a)+    -> Eff ff es a+callCC f = sub (\x -> f $ jump x) pure+{-# INLINE callCC #-}++getCC+    :: forall a ref es ff c+     . (CC ref :> es, Monad (Eff ff es), Free c ff)+    => Eff ff es (Eff ff es a)+getCC = callCC_ $ pure . fix+{-# INLINE getCC #-}

@@ -1,27 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.--module Data.Effect.Chronicle where--import Data.Functor (($>))-import Data.These (These (That, These, This))--data ChronicleF c a where-    Dictate :: c -> ChronicleF c ()-    Confess :: c -> ChronicleF c a--data ChronicleH c f a where-    Memento :: f a -> ChronicleH c f (Either c a)-    Absolve :: a -> f a -> ChronicleH c f a-    Condemn :: f a -> ChronicleH c f a--makeEffect [''ChronicleF] [''ChronicleH]--chronicle :: (ChronicleF c <: f, Applicative f) => These c a -> f a-chronicle = \case-    This c -> confess c-    That x -> pure x-    These c x -> dictate c $> x

@@ -1,10 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-}  -- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2024 Sayo Koyoneda+Copyright   :  (c) 2024-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -16,10 +18,27 @@ import Control.Applicative (liftA2) #endif import Control.Applicative (Alternative (empty, (<|>)))+import Control.Monad (forever)+import Data.Effect (Emb, UnliftIO)+import Data.Function (fix) import Data.Tuple (swap)+import UnliftIO (+    MonadIO,+    MonadUnliftIO,+    atomically,+    liftIO,+    mask,+    newEmptyTMVarIO,+    putTMVar,+    readTMVar,+    tryReadTMVar,+    uninterruptibleMask_,+    withRunInIO,+ )+import UnliftIO.Concurrent (forkIO, killThread, threadDelay)  -- | An `Applicative`-based effect for executing computations in parallel.-data Parallel f a where+data Parallel :: Effect where     -- | Executes two actions in parallel and blocks until both are complete.     -- Finally, aggregates the execution results based on the specified function.     LiftP2@@ -32,36 +51,44 @@         -> Parallel f c  -- | An effect that blocks a computation indefinitely.-data Halt (a :: Type) where+data Halt :: Effect where     -- | Blocks a computation indefinitely.-    Halt :: Halt a+    Halt :: Halt f a  {- | An effect that adopts the result of the computation that finishes first among two computations and cancels the other. -}-data Race f (a :: Type) where+data Race :: Effect where     -- | Adopts the result of the computation that finishes first among two     --   computations and cancels the other.     Race :: f a -> f a -> Race f a -makeEffect [''Halt] [''Parallel, ''Race]+makeEffectF ''Halt+makeEffectsH [''Parallel, ''Race]  {- | A wrapper that allows using the `Parallel` effect in the form of `Applicative` /  `Alternative` instances. -}-newtype Concurrently f a = Concurrently {runConcurrently :: f a}-    deriving (Functor)+newtype Concurrently ff es a = Concurrently {runConcurrently :: Eff ff es a} -instance (Parallel <<: f, Applicative f) => Applicative (Concurrently f) where+deriving instance (Functor (Eff ff es)) => Functor (Concurrently ff es)++instance+    (Parallel :> es, Applicative (Eff ff es), Free c ff)+    => Applicative (Concurrently ff es)+    where     pure = Concurrently . pure     {-# INLINE pure #-}      liftA2 f (Concurrently a) (Concurrently b) = Concurrently $ liftP2 f a b     {-# INLINE liftA2 #-} -instance (Race <<: f, Halt <: f, Parallel <<: f, Applicative f) => Alternative (Concurrently f) where+instance+    (Race :> es, Halt :> es, Parallel :> es, Applicative (Eff ff es), Free c ff)+    => Alternative (Concurrently ff es)+    where     empty = Concurrently halt     {-# INLINE empty #-} @@ -73,21 +100,22 @@ Finally, aggregates the execution results based on the specified function. -} liftP3-    :: (Parallel <<: f, Applicative f)+    :: forall a b c d es ff con+     . (Parallel :> es, Free con ff)     => (a -> b -> c -> d)     -- ^ A function that aggregates the three execution results.-    -> f a+    -> Eff ff es a     -- ^ The first action to be executed in parallel.-    -> f b+    -> Eff ff es b     -- ^ The second action to be executed in parallel.-    -> f c+    -> Eff ff es c     -- ^ The third action to be executed in parallel.-    -> f d+    -> Eff ff es d liftP3 f a b = liftP2 ($) (liftP2 f a b) {-# INLINE liftP3 #-}  -- | An effect that realizes polling and cancellation of actions running in parallel.-data Poll f a where+data Poll :: Effect where     -- | Performs polling on an action running in parallel in the form of a fold.     --     -- First, the parallel execution of two actions begins.@@ -107,39 +135,160 @@         -- ^ The second action to be executed in parallel; the target of polling.         -> Poll f r -makeEffectH [''Poll]+makeEffectH ''Poll  -- | Executes two actions in parallel. If the first action completes before the second, the second action is canceled. cancels-    :: (Poll <<: f, Applicative f)-    => f a+    :: forall a b es ff c+     . (Poll :> es, Applicative (Eff ff es), Free c ff)+    => Eff ff es a     -- ^ The action that controls the cancellation.-    -> f b+    -> Eff ff es b     -- ^ The action to be canceled.-    -> f (a, Maybe b)+    -> Eff ff es (a, Maybe b) cancels = poldl $ curry $ pure . Left {-# INLINE cancels #-}  -- | Executes two actions in parallel. If the second action completes before the first, the first action is canceled. cancelBy-    :: (Poll <<: f, Applicative f)-    => f a+    :: forall a b es ff c+     . (Poll :> es, Applicative (Eff ff es), Free c ff)+    => Eff ff es a     -- ^ The action to be canceled.-    -> f b+    -> Eff ff es b     -- ^ The action that controls the cancellation.-    -> f (Maybe a, b)+    -> Eff ff es (Maybe a, b) cancelBy = flip $ poldl $ curry $ pure . Left . swap {-# INLINE cancelBy #-}  -- | An effect for parallel computations based on a `Traversable` container @t@.-data For (t :: Type -> Type) f a where+data For (t :: Type -> Type) :: Effect where     -- | Executes in parallel the actions stored within a `Traversable` container @t@.     For :: t (f a) -> For t f (t a) -makeEffectH_ [''For]+makeEffectH_ ''For makeHFunctor' ''For \(t :< _) -> [t|Functor $t|]  -- | Converts the `Traversable` container-based parallel computation effect t`For` into the `Applicative`-based parallel computation effect `Parallel`.-forToParallel :: (Parallel <<: f, Traversable t, Applicative f) => For t f ~> f+forToParallel+    :: forall t a es ff c+     . (Parallel :> es, Traversable t, Applicative (Eff ff es), Free c ff)+    => For t (Eff ff es) a+    -> Eff ff es a forToParallel (For iters) = runConcurrently $ traverse Concurrently iters {-# INLINE forToParallel #-}++runConcurrentIO+    :: forall a es ff c+     . (UnliftIO :> es, Emb IO :> es, forall es'. Monad (Eff ff es'), Free c ff)+    => Eff ff (Parallel ': Race ': Poll ': Halt ': es) a+    -> Eff ff es a+runConcurrentIO = runHaltIO . runPollIO . runRaceIO . runParallelIO+{-# INLINE runConcurrentIO #-}++runParallelIO+    :: forall a es ff c+     . (UnliftIO :> es, Emb IO :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (Parallel ': es) a+    -> Eff ff es a+runParallelIO = interpret parallelToIO+{-# INLINE runParallelIO #-}++parallelToIO :: (MonadUnliftIO m) => Parallel ~~> m+parallelToIO (LiftP2 f a b) =+    withRunInIO \run -> do+        var <- newEmptyTMVarIO+        mask \restore -> do+            t <- forkIO do+                x <- restore $ run a+                atomically $ putTMVar var x++            y <- restore $ run b++            atomically do+                x <- readTMVar var+                pure $ f x y+                <* uninterruptibleMask_ (killThread t)+{-# INLINE parallelToIO #-}++runPollIO+    :: forall a es ff c+     . (Emb IO :> es, UnliftIO :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (Poll ': es) a+    -> Eff ff es a+runPollIO = interpret pollToIO+{-# INLINE runPollIO #-}++runRaceIO+    :: forall a es ff c+     . (Emb IO :> es, UnliftIO :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (Race ': es) a+    -> Eff ff es a+runRaceIO = interpret raceToIO+{-# INLINE runRaceIO #-}++runHaltIO+    :: forall a es ff c+     . (Emb IO :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (Halt ': es) a+    -> Eff ff es a+runHaltIO = interpret haltToIO+{-# INLINE runHaltIO #-}++raceToIO :: (MonadUnliftIO m) => Race ~~> m+raceToIO (Race a b) =+    withRunInIO \run -> do+        var <- newEmptyTMVarIO+        mask \restore -> do+            let runThread m = forkIO do+                    x <- restore $ run m+                    atomically $ putTMVar var x++            t1 <- runThread a+            t2 <- runThread b++            atomically (readTMVar var)+                <* uninterruptibleMask_ (killThread t1 *> killThread t2)+{-# INLINE raceToIO #-}++pollToIO :: (MonadUnliftIO m) => Poll ~~> m+pollToIO (Poldl f a b) =+    withRunInIO \run -> do+        var <- newEmptyTMVarIO+        mask \restore -> do+            t <- forkIO do+                x <- restore $ run b+                atomically $ putTMVar var x++            restore (run a) >>= fix \next acc -> do+                poll <- atomically $ tryReadTMVar var+                restore (run $ f acc poll) >>= \case+                    Left r -> do+                        uninterruptibleMask_ $ killThread t+                        pure r+                    Right acc' -> next acc'+{-# INLINE pollToIO #-}++haltToIO :: (MonadIO m) => Halt ~~> m+haltToIO Halt = liftIO $ forever $ threadDelay maxBound+{-# INLINE haltToIO #-}++runParallelAsSequential+    :: forall a es ff c+     . (Applicative (Eff ff es), Free c ff)+    => Eff ff (Parallel ': es) a+    -> Eff ff es a+runParallelAsSequential = interpret parallelToSequential+{-# INLINE runParallelAsSequential #-}++parallelToSequential :: (Applicative (Eff ff es)) => Parallel ~~> Eff ff es+parallelToSequential (LiftP2 f a b) = liftA2 f a b+{-# INLINE parallelToSequential #-}++runForAsParallel+    :: forall t a es ff c+     . (Parallel :> es, Traversable t, Applicative (Eff ff es), Free c ff)+    => Eff ff (For t ': es) a+    -> Eff ff es a+runForAsParallel = interpret forToParallel+{-# INLINE runForAsParallel #-}

@@ -1,11 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2024 Sayo Koyoneda+Copyright   :  (c) 2024-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -13,65 +11,81 @@ -} module Data.Effect.Concurrent.Timer where +import Control.Concurrent.Thread.Delay qualified as Thread+import Control.Effect (perform)+import Control.Effect.Interpret (interpose) import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Effect (Emb) import Data.Effect.Coroutine (Yield, yield) import Data.Function (fix) import Data.Functor ((<&>)) import Data.Time (DiffTime)+import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)+import GHC.Clock (getMonotonicTimeNSec)  -- | An effect for time-related operations.-data Timer a where+data Timer :: Effect where     -- | Retrieves the current relative time from an arbitrary fixed reference point.     --   The reference point does not change within the context of that scope.-    Clock :: Timer DiffTime+    Clock :: Timer f DiffTime     -- | Temporarily suspends computation for the specified duration.-    Sleep :: DiffTime -> Timer ()+    Sleep :: DiffTime -> Timer f () -makeEffectF [''Timer]+makeEffectF ''Timer  {- | Creates a scope where elapsed time can be obtained. An action to retrieve the elapsed time, re-zeroed at the start of the scope, is passed to the scope. -} withElapsedTime-    :: (Timer <: m, Monad m)-    => (m DiffTime -> m a)+    :: forall a es ff c+     . (Timer :> es, Monad (Eff ff es), Free c ff)+    => (Eff ff es DiffTime -> Eff ff es a)     -- ^ A scope where the elapsed time can be obtained.     -- An action to retrieve the elapsed time is passed as an argument.-    -> m a+    -> Eff ff es a withElapsedTime f = do     start <- clock     f $ clock <&> (`subtract` start)+{-# INLINE withElapsedTime #-}  -- | Returns the time taken for a computation along with the result as a pair.-measureTime :: (Timer <: m, Monad m) => m a -> m (DiffTime, a)+measureTime+    :: forall a es ff c+     . (Timer :> es, Monad (Eff ff es), Free c ff)+    => Eff ff es a+    -> Eff ff es (DiffTime, a) measureTime m = withElapsedTime \elapsedTime -> do     r <- m     elapsedTime <&> (,r)+{-# INLINE measureTime #-}  {- | Temporarily suspends computation until the relative time from the fixed reference point in the current scope's context, as given by the argument. If the specified resume time has already passed, returns the elapsed time (positive value) in `Just`. -}-sleepUntil :: (Timer <: m, Monad m) => DiffTime -> m (Maybe DiffTime)+sleepUntil :: forall es ff c. (Timer :> es, Monad (Eff ff es), Free c ff) => DiffTime -> Eff ff es (Maybe DiffTime) sleepUntil t = do     now <- clock     when (t > now) do         sleep $ t - now     pure if t < now then Just (now - t) else Nothing+{-# INLINE sleepUntil #-}  {- | Repeats a computation indefinitely. Controls so that each loop occurs at a specific time interval. If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled. -} runCyclic-    :: (Timer <: m, Monad m)-    => m DiffTime+    :: forall a es ff c+     . (Timer :> es, Monad (Eff ff es), Free c ff)+    => Eff ff es DiffTime     -- ^ An action called at the start of each loop to determine the time interval until the next loop.     --   For example, @pure 1@ would control the loop to have a 1-second interval.-    -> m ()+    -> Eff ff es ()     -- ^ The computation to repeat.-    -> m a+    -> Eff ff es a runCyclic deltaTime a = do     t0 <- clock     flip fix t0 \next t -> do@@ -79,18 +93,20 @@         a         delay <- sleepUntil t'         next $ maybe t' (t' +) delay+{-# INLINE runCyclic #-}  {- | Controls to repeat a specified computation at fixed time intervals. A specialized version of `runCyclic`. If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled. -} runPeriodic-    :: (Timer <: m, Monad m)+    :: forall a es ff c+     . (Timer :> es, Monad (Eff ff es), Free c ff)     => DiffTime     -- ^ Loop interval-    -> m ()+    -> Eff ff es ()     -- ^ The computation to repeat.-    -> m a+    -> Eff ff es a runPeriodic interval = runCyclic (pure interval) {-# INLINE runPeriodic #-} @@ -98,7 +114,11 @@ Calls `yield` of a coroutine at fixed intervals. If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled. -}-periodicTimer :: forall m a. (Timer <: m, Yield () () <: m, Monad m) => DiffTime -> m a+periodicTimer+    :: forall a es ff c+     . (Timer :> es, Yield () () :> es, Monad (Eff ff es), Free c ff)+    => DiffTime+    -> Eff ff es a periodicTimer interval = runPeriodic interval $ yield () {-# INLINE periodicTimer #-} @@ -107,13 +127,41 @@ Controls so that the time returned by `yield` becomes the time interval until the next loop. If the computation time exceeds and the requested interval cannot be realized, the excess delay occurs, which accumulates and is not canceled. -}-cyclicTimer :: forall m a. (Timer <: m, Yield () DiffTime <: m, Monad m) => m a+cyclicTimer+    :: forall a es ff c+     . (Timer :> es, Yield () DiffTime :> es, Monad (Eff ff es), Free c ff)+    => Eff ff es a cyclicTimer = runCyclic (yield ()) (pure ()) {-# INLINE cyclicTimer #-}  -- | An effect that realizes control of wait times such that the specified time becomes the interval until the next @wait@ when @wait@ is executed repeatedly.-data CyclicTimer a where+data CyclicTimer :: Effect where     -- | Controls the wait time so that when @wait@ is executed repeatedly, the specified time becomes the interval until the next @wait@.-    Wait :: DiffTime -> CyclicTimer ()+    Wait :: DiffTime -> CyclicTimer f () -makeEffectF [''CyclicTimer]+makeEffectF ''CyclicTimer++runTimerIO+    :: forall a ff es c+     . (Emb IO :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (Timer ': es) a+    -> Eff ff es a+runTimerIO =+    interpret \case+        Clock -> do+            t <- getMonotonicTimeNSec & liftIO+            pure $ picosecondsToDiffTime $ fromIntegral t * 1000+        Sleep t ->+            Thread.delay (diffTimeToPicoseconds t `quot` 1000_000) & liftIO+{-# INLINE runTimerIO #-}++-- | Re-zeros the clock time in the local scope.+restartClock :: forall a ff es c. (Timer :> es, Monad (Eff ff es), Free c ff) => Eff ff es a -> Eff ff es a+restartClock a = do+    t0 <- clock+    a & interpose \case+        Clock -> do+            t <- clock+            pure $ t - t0+        other -> perform other+{-# INLINE restartClock #-}

@@ -1,12 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.--module Data.Effect.Cont where--data CallCC m a where-    CallCC :: (forall r. (a -> m r) -> m a) -> CallCC m a--makeEffect' (def & noDeriveHFunctor) noExtTemplate [] [''CallCC]

@@ -1,12 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- | Copyright   : (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King-              (c) 2023-2024 Sayo Koyoneda+              (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -17,22 +15,19 @@ module Data.Effect.Coroutine where  import Control.Monad ((>=>))+import Data.Effect.Input (Input (Input))+import Data.Effect.Output (Output (Output))  {- | An effect for coroutines. Realizes an operation that transfers control to the caller of the computation with coroutines along with a value of type @a@, and receives a value of type @b@ from the caller. -}-data Yield a b (c :: Type) where+data Yield a b :: Effect where     -- | Transfers control to the caller of the computation with coroutines along with a value of type @a@, and receives a value of type @b@ from the caller.-    Yield :: a -> Yield a b b--makeEffectF [''Yield]+    Yield :: a -> Yield a b f b --- | A version of `yield` where the value returned from the caller of the computation with coroutines is unit.-yield_ :: (Yield a () <: f) => a -> f ()-yield_ = yield-{-# INLINE yield_ #-}+makeEffectF ''Yield  {- | The execution result when handling a computation that includes the t`Yield` effect. A computation that may include suspension.@@ -55,9 +50,12 @@     -> Status m a b x     -- ^ Computation status to extend     -> m (Status m a b r)-continueStatus kk = \case-    Done x -> kk x-    Continue a k -> pure . Continue a $ k >=> continueStatus kk+continueStatus kk = loop+  where+    loop = \case+        Done x -> kk x+        Continue a k -> pure . Continue a $ k >=> continueStatus kk+{-# INLINE continueStatus #-}  -- | Repeats the computation until the final result is obtained by continuing the computation using the specified handler each time it suspends. loopStatus@@ -67,6 +65,19 @@     -> Status m a b r     -- ^ A computation that may include suspension.     -> m r-loopStatus f = \case-    Done r -> pure r-    Continue a k -> f a >>= k >>= loopStatus f+loopStatus f = loop+  where+    loop = \case+        Done r -> pure r+        Continue a k -> f a >>= k >>= loopStatus f+{-# INLINE loopStatus #-}++-- | Converts the t'Input' effect into the [coroutine]("Data.Effect.Coroutine")'s t'Yield' effect.+inputToYield :: Input i f a -> Yield () i f a+inputToYield Input = Yield ()+{-# INLINE inputToYield #-}++-- | Converts the t'Output' effect into the [coroutine]("Data.Effect.Coroutine")'s t'Yield' effect.+outputToYield :: Output o f a -> Yield o () f a+outputToYield (Output o) = Yield o+{-# INLINE outputToYield #-}

@@ -1,42 +1,36 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuantifiedConstraints #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp  An effect to escape from the normal control structure with an exception value in the middle of a context. -}-module Data.Effect.Except where---- | An effect to escape from the normal control structure with an exception value of type @e@ in the middle of a context.-data Throw e (a :: Type) where-    -- | Throws an exception; that is, escapes from the normal control structure with an exception value in the middle of a context.-    Throw :: e -> Throw e a+module Data.Effect.Except (+    module Data.Effect.Except,+    Catch (..),+    Throw (..),+)+where --- | An effect to catch exceptions.-data Catch e f (a :: Type) where-    -- | Catches exceptions within a scope and processes them according to the given exception handler.-    Catch-        :: f a-        -- ^ The scope in which to catch exceptions.-        -> (e -> f a)-        -- ^ Exception handler. Defines the processing to perform when an exception is thrown within the scope.-        -> Catch e f a+import Data.Effect (Catch (Catch), Emb, Throw (Throw), UnliftIO)+import UnliftIO (Exception, throwIO)+import UnliftIO qualified as IO -makeEffect [''Throw] [''Catch]+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Throw+makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''Catch  -- | Throws the given `Either` value as an exception if it is `Left`.-liftEither :: (Throw e <: f, Applicative f) => Either e a -> f a+liftEither :: forall e es a ff c. (Throw e :> es, Applicative (Eff ff es), Free c ff) => Either e a -> Eff ff es a liftEither = either throw pure {-# INLINE liftEither #-}  -- | Throws the result of the given action as an exception if it is `Left`.-joinEither :: (Throw e <: m, Monad m) => m (Either e a) -> m a+joinEither :: forall e es a ff c. (Throw e :> es, Monad (Eff ff es), Free c ff) => Eff ff es (Either e a) -> Eff ff es a joinEither = (>>= either throw pure) {-# INLINE joinEither #-} @@ -52,23 +46,42 @@  -- | If an exception occurs, executes the given exception handler, but the exception is not stopped there and is rethrown. withExcept-    :: (Catch e <<: f, Throw e <: f, Applicative f)-    => f a+    :: forall e es a ff c+     . (Catch e :> es, Throw e :> es, Applicative (Eff ff es), Free c ff)+    => Eff ff es a     -- ^ Scope to which the exception handler applies-    -> (e -> f ())+    -> (e -> Eff ff es ())     -- ^ Exception handler-    -> f a+    -> Eff ff es a withExcept thing after = thing `catch` \e -> after e *> throw e {-# INLINE withExcept #-}  -- | If an exception occurs, executes the specified action, but the exception is not stopped there and is rethrown. onExcept-    :: forall e f a-     . (Catch e <<: f, Throw e <: f, Applicative f)-    => f a+    :: forall e es ff a c+     . (Catch e :> es, Throw e :> es, Applicative (Eff ff es), Free c ff)+    => Eff ff es a     -- ^ Scope in which to detect exceptions-    -> f ()+    -> Eff ff es ()     -- ^ Action to execute in case of an exception-    -> f a+    -> Eff ff es a onExcept thing after = thing `withExcept` \(_ :: e) -> after {-# INLINE onExcept #-}++-- | Interpret the t'Throw' effect based on an IO-fused semantics using IO-level exceptions.+runThrowIO+    :: forall e es ff a c+     . (Emb IO :> es, Exception e, Monad (Eff ff es), Free c ff)+    => Eff ff (Throw e ': es) a+    -> Eff ff es a+runThrowIO = interpret \(Throw e) -> throwIO e+{-# INLINE runThrowIO #-}++-- | Interpret the t'Catch' effect based on an IO-fused semantics using IO-level exceptions.+runCatchIO+    :: forall e es ff a c+     . (UnliftIO :> es, Emb IO :> es, Exception e, Monad (Eff ff es), Free c ff)+    => Eff ff (Catch e ': es) a+    -> Eff ff es a+runCatchIO = interpret \(Catch action hdl) -> IO.catch action hdl+{-# INLINE runCatchIO #-}

@@ -1,12 +1,29 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0 -module Data.Effect.Fail where+{- |+Copyright   :  (c) 2025 Sayo contributors+License     :  MPL-2.0 (see the file LICENSE)+Maintainer  :  ymdfield@outlook.jp+-}+module Data.Effect.Fail (+    module Data.Effect.Fail,+    Fail (..),+)+where -data Fail (a :: Type) where-    Fail :: String -> Fail a+import Control.Monad.IO.Class (liftIO)+import Data.Effect (Emb, Fail (Fail))+import Prelude hiding (fail)+import Prelude qualified as IO -makeEffectF [''Fail]+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Fail++runFailIO+    :: forall es a ff c+     . (Emb IO :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (Fail ': es) a+    -> Eff ff es a+runFailIO = interpret \(Fail s) -> liftIO $ IO.fail s+{-# INLINE runFailIO #-}

@@ -1,12 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0 -module Data.Effect.Fix where+{- |+Copyright   :  (c) 2025 Sayo contributors+License     :  MPL-2.0 (see the file LICENSE)+Maintainer  :  ymdfield@outlook.jp+-}+module Data.Effect.Fix (+    module Data.Effect.Fix,+    Fix (..),+)+where -data Fix f a where-    Mfix :: (a -> f a) -> Fix f a+import Data.Effect (Fix (Efix)) -makeEffectH [''Fix]+makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''Fix

@@ -1,19 +1,15 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2024-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable -} module Data.Effect.Fresh where -data Fresh i (a :: Type) where-    Fresh :: Fresh i i+data Fresh i :: Effect where+    Fresh :: Fresh i f i -makeEffectF [''Fresh]+makeEffectF ''Fresh

@@ -1,11 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -18,12 +16,37 @@ module Data.Effect.Input where  -- | A general effect representing input of values from the external world.-data Input i (a :: Type) where+data Input i :: Effect where     -- | Retrieve a value input from the external world.-    Input :: Input i i+    Input :: Input i f i -makeEffectF [''Input]+makeEffectF ''Input  -- | Returns the value obtained by transforming the input value using the given function.-inputs :: (Input i <: f, Functor f) => (i -> a) -> f a+inputs+    :: forall i es ff a c+     . (Input i :> es, Functor (Eff ff es), Free c ff)+    => (i -> a)+    -> Eff ff es a inputs f = f <$> input+{-# INLINE inputs #-}++-- | Interprets the t'Input' effect by executing the given input handler each time an input is required.+runInputEff+    :: forall i es ff a c+     . (Free c ff)+    => Eff ff es i+    -> Eff ff (Input i ': es) a+    -> Eff ff es a+runInputEff a = interpret \Input -> a+{-# INLINE runInputEff #-}++-- | Interprets the t'Input' effect by providing the given constant as input.+runInputConst+    :: forall i es ff a c+     . (Applicative (Eff ff es), Free c ff)+    => i+    -> Eff ff (Input i ': es) a+    -> Eff ff es a+runInputConst i = interpret \Input -> pure i+{-# INLINE runInputConst #-}

@@ -1,15 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2024 Sayo Koyoneda+Copyright   :  (c) 2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable  This module provides the t`KVStore` effect, comes from [@Polysemy.KVStore@](https://hackage.haskell.org/package/polysemy-kvstore-0.1.3.0/docs/Polysemy-KVStore.html)@@ -17,32 +15,73 @@ -} module Data.Effect.KVStore where +import Control.Arrow ((>>>))+import Control.Effect.Transform (raiseUnder)+import Data.Effect (Emb) import Data.Effect.Except (Throw, throw)+import Data.Effect.State (State, get, modify, runStateIORef)+import Data.Functor ((<&>))+import Data.Map (Map)+import Data.Map qualified as Map import Data.Maybe (isJust) -data KVStore k v a where-    LookupKV :: k -> KVStore k v (Maybe v)-    UpdateKV :: k -> Maybe v -> KVStore k v ()+data KVStore k v :: Effect where+    LookupKV :: k -> KVStore k v f (Maybe v)+    UpdateKV :: k -> Maybe v -> KVStore k v f () -makeEffectF [''KVStore]+makeEffectF ''KVStore -lookupOrThrowKV :: (KVStore k v <: m, Throw e <: m, Monad m) => (k -> e) -> k -> m v+lookupOrThrowKV+    :: forall k v e es ff c+     . (KVStore k v :> es, Throw e :> es, Monad (Eff ff es), Free c ff)+    => (k -> e)+    -> k+    -> Eff ff es v lookupOrThrowKV err k =     lookupKV k >>= maybe (throw $ err k) pure+{-# INLINE lookupOrThrowKV #-} -existsKV :: forall v k f. (KVStore k v <: f, Functor f) => k -> f Bool+existsKV :: forall v k es ff c. (KVStore k v :> es, Functor (Eff ff es), Free c ff) => k -> Eff ff es Bool existsKV = fmap isJust . lookupKV @k @v {-# INLINE existsKV #-} -writeKV :: KVStore k v <: f => k -> v -> f ()+writeKV :: forall k v es ff c. (KVStore k v :> es, Free c ff) => k -> v -> Eff ff es () writeKV k v = updateKV k (Just v) {-# INLINE writeKV #-} -deleteKV :: forall v k f. KVStore k v <: f => k -> f ()+deleteKV :: forall v k es ff c. (KVStore k v :> es, Free c ff) => k -> Eff ff es () deleteKV k = updateKV @k @v k Nothing {-# INLINE deleteKV #-} -modifyKV :: (KVStore k v <: m, Monad m) => v -> (v -> v) -> k -> m ()+modifyKV+    :: forall k v es ff c+     . (KVStore k v :> es, Monad (Eff ff es), Free c ff)+    => v+    -> (v -> v)+    -> k+    -> Eff ff es () modifyKV vDefault f k = do     v <- lookupKV k     updateKV k (Just $ maybe vDefault f v)+{-# INLINE modifyKV #-}++runKVStoreIORef+    :: forall k v a es ff c+     . (Ord k, Emb IO :> es, forall es'. Monad (Eff ff es'), Free c ff)+    => Map k v+    -> Eff ff (KVStore k v ': es) a+    -> Eff ff es (Map k v, a)+runKVStoreIORef initial =+    raiseUnder+        >>> runKVStoreAsState+        >>> runStateIORef initial+{-# INLINE runKVStoreIORef #-}++runKVStoreAsState+    :: forall k v es ff c+     . (Ord k, State (Map k v) :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (KVStore k v ': es) ~> Eff ff es+runKVStoreAsState = interpret \case+    LookupKV k -> get <&> Map.lookup k+    UpdateKV k v -> modify $ Map.update (const v) k+{-# INLINE runKVStoreAsState #-}

@@ -2,8 +2,39 @@  -- SPDX-License-Identifier: MPL-2.0 +{- |+Copyright   :  (c) 2024-2025 Sayo contributors+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp++Interpreters for the [@co-log@](https://hackage.haskell.org/package/co-log) ecosystem.++The interface is similar to [@co-log-polysemy@](https://hackage.haskell.org/package/co-log-polysemy).+-} module Data.Effect.Log where -data Log msg a where-    Log :: msg -> Log msg ()-makeEffectF [''Log]+import Colog.Core (LogAction (LogAction))+import Control.Effect (emb)+import Data.Effect (Emb)+import Data.Effect.Output (Output (Output), output)+import Prelude hiding (log)++data Log msg :: Effect where+    Log :: msg -> Log msg f ()+makeEffectF ''Log++runLogAsOutput :: forall msg a es ff c. (Output msg :> es, Free c ff) => Eff ff (Log msg ': es) a -> Eff ff es a+runLogAsOutput = interpret \(Log msg) -> output msg+{-# INLINE runLogAsOutput #-}++runOutputAsLog :: forall msg a es ff c. (Log msg :> es, Free c ff) => Eff ff (Output msg ': es) a -> Eff ff es a+runOutputAsLog = interpret \(Output msg) -> log msg+{-# INLINE runOutputAsLog #-}++runLogAction :: forall msg a es ff c. (Free c ff) => LogAction (Eff ff es) msg -> Eff ff (Log msg ': es) a -> Eff ff es a+runLogAction (LogAction f) = interpret \(Log msg) -> f msg+{-# INLINE runLogAction #-}++runLogActionEmbed :: forall msg f a es ff c. (Emb f :> es, Free c ff) => LogAction f msg -> Eff ff (Log msg ': es) a -> Eff ff es a+runLogActionEmbed (LogAction f) = interpret \(Log msg) -> emb $ f msg+{-# INLINE runLogActionEmbed #-}

@@ -1,40 +1,120 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   : (c) 2024 Sayo Koyoneda+Copyright   : (c) 2024-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp  Effects that realize non-deterministic computations. -}-module Data.Effect.NonDet where+module Data.Effect.NonDet (+    module Data.Effect.NonDet,+    Empty (..),+    Choose (..),+    ChooseH (..),+)+where --- | An effect that eliminates a branch by causing the current branch context of a non-deterministic computation to fail.-data Empty (a :: Type) where-    -- | Eliminates a branch by causing the current branch context of a non-deterministic computation to fail.-    Empty :: Empty a+#if ( __GLASGOW_HASKELL__ < 906 )+import Control.Applicative (liftA2)+#endif+import Control.Applicative ((<|>))+import Control.Effect.Interpret (interprets)+import Control.Exception (Exception, SomeException)+import Data.Bool (bool)+import Data.Effect (Choose (Choose), ChooseH (ChooseH), Emb, Empty (Empty), Shift, UnliftIO)+import Data.Effect.OpenUnion (nil, (!:))+import Data.Effect.Shift (abort, shift)+import UnliftIO (throwIO, try) -makeEffectF [''Empty]+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Empty+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Choose+makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''ChooseH --- | An effect that splits the computation into two branches.-data Choose (a :: Type) where-    -- | Splits the computation into two branches.-    -- As a result of executing @choose@, the world branches into one where `False` is returned and one where `True` is returned.-    Choose :: Choose Bool+{- | t'ChooseH' effect elaborator. -makeEffectF [''Choose]+    Convert a higher-order effect of the form +        @chooseH :: m a -> m a -> m a@++    into a first-order effect of the form:++        @choose :: m Bool@+-}+runChooseH+    :: forall es a ff c+     . (Choose :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (ChooseH ': es) a+    -> Eff ff es a+runChooseH = interpret \(ChooseH a b) -> branch a b+{-# INLINE runChooseH #-}++-- | Faster than `<|>`.+branch :: forall es a ff c. (Choose :> es, Monad (Eff ff es), Free c ff) => Eff ff es a -> Eff ff es a -> Eff ff es a+branch a b = do+    world <- choose+    bool a b world+{-# INLINE branch #-}++infixl 3 `branch`++-- | Selects one element from the list nondeterministically, branching the control as many times as the number of elements.+choice :: forall es a ff c. (Choose :> es, Empty :> es, Monad (Eff ff es), Free c ff) => [a] -> Eff ff es a+choice = \case+    [] -> empty+    x : xs -> pure x `branch` choice xs+{-# INLINE choice #-}++-- | Selects one element from the list nondeterministically, branching the control as many times as the number of elements. Uses t'ChooseH'.+choiceH :: forall es a ff c. (ChooseH :> es, Empty :> es, Monad (Eff ff es), Free c ff) => [a] -> Eff ff es a+choiceH = \case+    [] -> empty+    x : xs -> pure x <|> choiceH xs+{-# INLINE choiceH #-}++runNonDetShift+    :: forall ans a es ref ff c+     . (Monoid ans, Shift ans ref :> es, forall f. Monad (ff f), Free c ff)+    => Eff ff (Choose ': Empty ': es) a+    -> Eff ff es a+runNonDetShift =+    interprets $+        (\Choose -> shift \k' -> liftA2 (<>) (k' True) (k' False))+            !: (\Empty -> abort mempty)+            !: nil+{-# INLINE runNonDetShift #-}+ {- |-An effect that executes two branches as scopes.-A higher-order version of the t`Choose` effect.+Interprets the [NonDet]("Data.Effect.NonDet") effects using IO-level exceptions.++When 'empty' occurs, an v'EmptyException' is thrown, and unless all branches from+ 'chooseH' fail due to IO-level exceptions, only the leftmost result is returned+ as the final result. -}-data ChooseH f (a :: Type) where-    -- | Executes the given two scopes as branches.-    -- Even if one fails due to the `empty` operation, the whole does not fail as long as the other does not fail.-    ChooseH :: f a -> f a -> ChooseH f a+runNonDetIO+    :: forall es a ff c+     . (UnliftIO :> es, Emb IO :> es, forall f. Monad (Eff ff f), Free c ff)+    => Eff ff (ChooseH ': Empty ': es) a+    -> Eff ff es (Either SomeException a)+runNonDetIO m = try do+    let hdl =+            ( \(ChooseH a b) ->+                try a >>= \case+                    Right x -> pure x+                    Left (_ :: SomeException) -> b+            )+                !: (\Empty -> throwIO EmptyException)+                !: nil+     in interprets hdl m+{-# INLINE runNonDetIO #-} -makeEffectH [''ChooseH]+-- | Exception thrown when 'empty' occurs in 'runNonDetIO'.+data EmptyException = EmptyException+    deriving stock (Show)+    deriving anyclass (Exception)

@@ -1,11 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -18,8 +16,27 @@ module Data.Effect.Output where  -- | A general effect representing output of values to the external world.-data Output o a where+data Output o :: Effect where     -- | Output a value to the external world.-    Output :: o -> Output o ()+    Output :: o -> Output o f () -makeEffectF [''Output]+makeEffectF ''Output++-- | Interprets the t'Output' effect using the given output handler.+runOutputEff+    :: forall o es ff a c+     . (Free c ff)+    => (o -> Eff ff es ())+    -> Eff ff (Output o ': es) a+    -> Eff ff es a+runOutputEff f = interpret \(Output o) -> f o+{-# INLINE runOutputEff #-}++-- | Interprets the t'Output' effect by ignoring the outputs.+ignoreOutput+    :: forall o es ff a c+     . (Applicative (Eff ff es), Free c ff)+    => Eff ff (Output o ': es) a+    -> Eff ff es a+ignoreOutput = runOutputEff $ const $ pure ()+{-# INLINE ignoreOutput #-}

@@ -1,11 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023-2024 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -14,71 +14,165 @@ -} module Data.Effect.Provider where -import Data.Effect.HFunctor (HFunctor, hfmap)-import Data.Effect.Key (type (##>))+import Control.Effect.Transform (raise, raisePrefix, raisePrefix1)+import Data.Effect.OpenUnion (Each, KnownLength, type (++)) import Data.Functor.Const (Const (Const))-import Data.Functor.Identity (Identity, runIdentity)+import Data.Functor.Identity (Identity (Identity), runIdentity) --- | An effect to introduce a new local scope that provides effect context @b@.-data Provider' ctx i b (f :: Type -> Type) (a :: Type) where-    -- | Introduces a new local scope that provides an effect context @b p@ parameterized by type @i p@ and with results wrapped in @ctx p@.-    Provide-        :: i p-        -> ((forall x. f x -> b p x) -> b p a)-        -> Provider' ctx i b f (ctx p a)+-- | An effect to introduce a new local scope that provides effect context @b s@.+data Scope t i b :: Effect where+    -- | Introduces a new local scope that provides an effect context @b s@ parameterized by type @i s@ and with results wrapped in @t s@.+    Scope+        :: forall s t i a f b+         . i s+        -> ((forall x. f x -> b s x) -> b s a)+        -> Scope t i b f (t s a) -makeEffectH [''Provider']+makeEffectH' (def & noGenerateLabel) ''Scope --- | A type-level key to uniquely resolve the effect context carrier @b@ from @ctx@ and @i@.-data ProviderKey ctx i+-- | A type-level label to uniquely resolve the effect context carrier @b@ from @t@ and @i@.+data ScopeLabel (t :: k -> Type -> Type) (i :: k -> Type) --- | An effect to introduce a new local scope that provides effect context @b@.-type Provider ctx i b = ProviderKey ctx i ##> Provider' ctx i b+type instance LabelOf (Scope t i b) = ScopeLabel t i -{- |-An effect to introduce a new local scope that provides effect context @b@.-A version of `Provider` where the result is not wrapped in a specific container.--}-type Provider_ i b = Provider (Const1 Identity) (Const i :: () -> Type) (Const1 b)+newtype Const1 f x (a :: Type) = Const1 {getConst1 :: f a} -newtype Const1 f x a = Const1 {getConst1 :: f a}+-- | An effect to introduce a new local scope that provides the scope-parametrized effect @e@.+type Scoped ff t i es r = Scope t i (ScopeC ff t i es r) -newtype Const2 ff x f a = Const2 {getConst2 :: ff f a}-instance (HFunctor ff) => HFunctor (Const2 ff x) where-    hfmap phi (Const2 ff) = Const2 $ hfmap phi ff-    {-# INLINE hfmap #-}+newtype ScopeC ff t i fs r s a+    = ScopeC {unScopeC :: Eff ff (Each fs s ++ Scoped ff t i fs r ': r) a} -infix 2 .!+-- | An effect to introduce a new local scope that provides the effect @e@.+type Scoped_ ff t i es r = Scope t i (Const1 (ScopeC_ ff t i es r)) -{- | A operator to introduce a new local scope that provides effect context @b@.-A version of `..!` where the result is not wrapped in a specific container.--}-(.!)-    :: forall i f a b-     . ( SendHOEBy-            (ProviderKey (Const1 Identity :: () -> Type -> Type) (Const i :: () -> Type))-            (Provider' (Const1 Identity) (Const i) (Const1 b))-            f-       , Functor f+newtype ScopeC_ ff t i es r a+    = ScopeC_ {unScopeC_ :: Eff ff (es ++ Scoped_ ff t i es r ': r) a}++type Provider ff t i e es = Scoped_ ff (Const1 t) (Const i :: () -> Type) e es++runScoped+    :: forall t i a es r ff c+     . (KnownLength es, Free c ff)+    => ( forall s x+          . i s+         -> Eff ff (Each es s ++ Scoped ff t i es r ': r) x+         -> Eff ff (Scoped ff t i es r ': r) (t s x)        )+    -> Eff ff (Scoped ff t i es r ': r) a+    -> Eff ff r a+runScoped run = loop+  where+    loop :: Eff ff (Scoped ff t i es r ': r) ~> Eff ff r+    loop = interpret \(Scope (i :: i s) f) ->+        loop $ run i (unScopeC $ f $ ScopeC . raisePrefix1 @es @s . raise @(Scoped ff t i es r))+{-# INLINE runScoped #-}++scoped+    :: forall t i s a es' es r ff c+     . (Scoped ff t i es r :> es', Free c ff)+    => i s+    -> ( Eff ff es' ~> Eff ff (Each es s ++ Scoped ff t i es r ': r)+         -> Eff ff (Each es s ++ Scoped ff t i es r ': r) a+       )+    -> Eff ff es' (t s a)+scoped i f = scope i \detach -> ScopeC $ f $ unScopeC . detach+{-# INLINE scoped #-}++runScoped_+    :: forall t i a es r ff c+     . (KnownLength es, Free c ff)+    => ( forall p x+          . i p+         -> Eff ff (es ++ Scoped_ ff t i es r ': r) x+         -> Eff ff (Scoped_ ff t i es r ': r) (t p x)+       )+    -> Eff ff (Scoped_ ff t i es r ': r) a+    -> Eff ff r a+runScoped_ run = loop+  where+    loop :: Eff ff (Scoped_ ff t i es r ': r) ~> Eff ff r+    loop = interpret \(Scope i f) ->+        loop $ run i (unScopeC_ . getConst1 $ f $ Const1 . ScopeC_ . raisePrefix @es . raise @(Scoped_ ff t i es r))+{-# INLINE runScoped_ #-}++scoped_+    :: forall t i s a es' es r ff c+     . (Scoped_ ff t i es r :> es', Free c ff)+    => i s+    -> ( Eff ff es' ~> Eff ff (es ++ Scoped_ ff t i es r ': r)+         -> Eff ff (es ++ Scoped_ ff t i es r ': r) a+       )+    -> Eff ff es' (t s a)+scoped_ i f = scope i \pop -> Const1 $ ScopeC_ $ f $ unScopeC_ . getConst1 . pop+{-# INLINE scoped_ #-}++runProvider+    :: forall t i a es r ff c+     . (forall es'. Functor (Eff ff es'), KnownLength es, Free c ff)+    => ( forall x+          . i+         -> Eff ff (es ++ Provider ff t i es r ': r) x+         -> Eff ff (Provider ff t i es r ': r) (t x)+       )+    -> Eff ff (Provider ff t i es r ': r) a+    -> Eff ff r a+runProvider run = runScoped_ \(Const i) a -> Const1 <$> run i a+{-# INLINE runProvider #-}++provide+    :: forall t i a es' es r ff c+     . (Provider ff t i es r :> es', forall es''. Functor (Eff ff es''), Free c ff)     => i-    -> ((f ~> b) -> b a)-    -> f a-i .! f =-    runIdentity . getConst1-        <$> provide'' @(ProviderKey (Const1 Identity :: () -> _ -> _) (Const i :: () -> _))-            (Const i)-            \run -> Const1 $ f $ getConst1 . run-{-# INLINE (.!) #-}+    -> ( Eff ff es' ~> Eff ff (es ++ Provider ff t i es r ': r)+         -> Eff ff (es ++ Provider ff t i es r ': r) a+       )+    -> Eff ff es' (t a)+provide i f = getConst1 <$> scoped_ @_ @_ @'() (Const i) f+{-# INLINE provide #-} -infix 2 ..!+runProvider_+    :: forall i a es r ff c+     . (forall es'. Functor (Eff ff es'), KnownLength es, Free c ff)+    => ( forall x+          . i+         -> Eff ff (es ++ Provider ff Identity i es r ': r) x+         -> Eff ff (Provider ff Identity i es r ': r) x+       )+    -> Eff ff (Provider ff Identity i es r ': r) a+    -> Eff ff r a+runProvider_ run = runProvider \i a -> Identity <$> run i a+{-# INLINE runProvider_ #-} --- | A operator to introduce a new local scope that provides effect context @b p@.-(..!)-    :: forall ctx i p f a b-     . (SendHOEBy (ProviderKey ctx i) (Provider' ctx i b) f)-    => i p-    -> ((f ~> b p) -> b p a)-    -> f (ctx p a)-i ..! f = provide'' @(ProviderKey ctx i) i f-{-# INLINE (..!) #-}+provide_+    :: forall i a es' es r ff c+     . (Provider ff Identity i es r :> es', forall es''. Functor (Eff ff es''), Free c ff)+    => i+    -> ( Eff ff es' ~> Eff ff (es ++ Provider ff Identity i es r ': r)+         -> Eff ff (es ++ Provider ff Identity i es r ': r) a+       )+    -> Eff ff es' a+provide_ i f = runIdentity <$> provide i f+{-# INLINE provide_ #-}++runProvider__+    :: forall a es r ff c+     . (forall es'. Functor (Eff ff es'), KnownLength es, Free c ff)+    => ( forall x+          . Eff ff (es ++ Provider ff Identity () es r ': r) x+         -> Eff ff (Provider ff Identity () es r ': r) x+       )+    -> Eff ff (Provider ff Identity () es r ': r) a+    -> Eff ff r a+runProvider__ run = runProvider_ \() -> run+{-# INLINE runProvider__ #-}++provide__+    :: forall a es' es r ff c+     . (Provider ff Identity () es r :> es', forall es''. Functor (Eff ff es''), Free c ff)+    => ( Eff ff es' ~> Eff ff (es ++ Provider ff Identity () es r ': r)+         -> Eff ff (es ++ Provider ff Identity () es r ': r) a+       )+    -> Eff ff es' a+provide__ = provide_ ()+{-# INLINE provide__ #-}

@@ -1,11 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp @@ -13,25 +13,72 @@ Environmental values are immutable and do not change across procedures, but you can modify the value within a local scope using the `local` operation. -}-module Data.Effect.Reader where---- | An effect that holds a value of type @r@ in the context (environment).-data Ask r (a :: Type) where-    -- | Obtain a value from the environment.-    Ask :: Ask r r+module Data.Effect.Reader (+    module Data.Effect.Reader,+    Ask (..),+    Local (..),+)+where --- | An effect that locally modifies the value held in the environment.-data Local r f (a :: Type) where-    -- | Locally modifies the value held in the environment.-    Local-        :: (r -> r)-        -- ^ A function that transforms the original value to the modified value.-        -> f a-        -- ^ The local scope where the modification is applied.-        -> Local r f a+import Control.Effect (sendFor)+import Control.Effect.Interpret (interposeFor)+import Data.Effect (Ask (Ask), Local (Local))+import Data.Effect.OpenUnion (IdentityResolver, Membership, membership) -makeEffect [''Ask] [''Local]+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Ask+makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''Local  -- | Obtains a value from the environment and returns it transformed by the given function.-asks :: (Ask r <: f, Functor f) => (r -> a) -> f a+asks+    :: forall r es ff a c+     . (Ask r :> es, Functor (Eff ff es), Free c ff)+    => (r -> a)+    -> Eff ff es a asks f = f <$> ask+{-# INLINE asks #-}++-- | Interpret the t'Ask'/t'Local' effects.+runReader+    :: forall r es ff a c+     . (forall es'. Applicative (Eff ff es'), Free c ff)+    => r+    -> Eff ff (Local r ': Ask r ': es) a+    -> Eff ff es a+runReader r = runAsk r . runLocal+{-# INLINE runReader #-}++-- | Interpret the t'Ask' effect.+runAsk+    :: forall r es ff a c+     . (Applicative (Eff ff es), Free c ff)+    => r+    -> Eff ff (Ask r ': es) a+    -> Eff ff es a+runAsk r = interpret \Ask -> pure r+{-# INLINE runAsk #-}++-- | Interpret the t'Local' effect.+runLocal+    :: forall r es ff a c+     . (Applicative (Eff ff es), Ask r `In` es, Free c ff)+    => Eff ff (Local r ': es) a+    -> Eff ff es a+runLocal = interpret handleLocal+{-# INLINE runLocal #-}++-- | A handler for the t'Local' effect.+handleLocal+    :: forall r es ff c+     . (Applicative (Eff ff es), Ask r `In` es, Free c ff)+    => Local r ~~> Eff ff es+handleLocal = handleLocalFor $ membership @IdentityResolver+{-# INLINE handleLocal #-}++-- | A handler for the t'Local' effect.+handleLocalFor+    :: forall r es ff c+     . (Applicative (Eff ff es), Free c ff)+    => Membership (Ask r) es+    -> Local r ~~> Eff ff es+handleLocalFor pr (Local f a) = a & interposeFor pr \Ask -> f <$> sendFor pr Ask+{-# INLINE handleLocalFor #-}

@@ -1,56 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.---- The code and documentation before modification is BSD3 licensed,--- (c) 2019-2023 The Polysemy Lounge: [Polysemy.Resource]--- (https://hackage.haskell.org/package/polysemy-1.9.1.2/docs/Polysemy-Resource.html).--{- |-Copyright   :  (c) 2019-2023 The Polysemy Lounge-               (c) 2023 Sayo Koyoneda-License     :  MPL-2.0 (see the file LICENSE)-Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable--An effect capable of providing [bracket]-(https://hackage.haskell.org/package/base-4.16.4.0/docs/Control-Exception.html#v:bracket) semantics.--}-module Data.Effect.Resource where--import Data.Functor (void)--{- |-An effect capable of providing [bracket]-(https://hackage.haskell.org/package/base-4.16.4.0/docs/Control-Exception.html#v:bracket) semantics.--}-data Resource f a where-    -- | Allocate a resource, use it, and clean it up afterwards.-    Bracket :: f a -> (a -> f ()) -> (a -> f b) -> Resource f b-    -- | Allocate a resource, use it, and clean it up afterwards if an error occurred.-    BracketOnExcept :: f a -> (a -> f ()) -> (a -> f b) -> Resource f b--makeEffectH [''Resource]--bracket_ :: (Resource <<: f, Functor f) => f a -> f b -> f c -> f c-bracket_ acquire release thing =-    bracket acquire (const $ void release) (const thing)--bracketOnExcept_ :: (Resource <<: f, Functor f) => f a -> f b -> f c -> f c-bracketOnExcept_ acquire onExc thing =-    bracketOnExcept acquire (const $ void onExc) (const thing)--finally :: (Resource <<: f, Applicative f) => f a -> f () -> f a-finally thing release = bracket (pure ()) (const release) (const thing)--finally_ :: (Resource <<: f, Applicative f) => f a -> f b -> f a-finally_ thing release = finally thing (void release)--onException :: (Resource <<: f, Applicative f) => f a -> f () -> f a-onException thing onExc = bracketOnExcept (pure ()) (const onExc) (const thing)--onException_ :: (Resource <<: f, Applicative f) => f a -> f b -> f a-onException_ thing onExc = onException thing (void onExc)

@@ -1,12 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  module Data.Effect.Select where -data Select r a where-    Select :: ((a -> r) -> a) -> Select r a+data Select r :: Effect where+    Select :: ((a -> r) -> a) -> Select r f a -makeEffectF [''Select]+makeEffectF ''Select

@@ -0,0 +1,61 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- SPDX-License-Identifier: MPL-2.0++{- |+Copyright   :  (c) 2025 Sayo contributors+License     :  MPL-2.0 (see the LICENSE file)+Maintainer  :  ymdfield@outlook.jp+-}+module Data.Effect.Shift where++import Control.Monad ((<=<))+import Data.Effect (CC (Jump, SubFork), Shift)+import Data.Function (fix)+import Data.Functor.Contravariant (Op (Op))++makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Shift++subShift+    :: forall a b es ans ref ff c+     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)+    => (ref a -> Eff ff es b)+    -> (a -> Eff ff es b)+    -> Eff ff es b+subShift p q = subShiftFork >>= either p q+{-# INLINE subShift #-}++shift+    :: forall a es ans ref ff c+     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)+    => ((a -> Eff ff es ans) -> Eff ff es ans)+    -> Eff ff es a+shift f = subShift (abort <=< f . call) pure+{-# INLINE shift #-}++getShiftCC+    :: forall es ans ref ff c+     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)+    => Eff ff es (Eff ff es ans)+getShiftCC = shift fix+{-# INLINE getShiftCC #-}++runCCAsShift+    :: forall a es ans ref ff c+     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (CC ref ': es) a+    -> Eff ff es a+runCCAsShift = interpret \case+    SubFork -> subShiftFork+    Jump ref x -> call ref x >>= abort+{-# INLINE runCCAsShift #-}++runCCOnShift+    :: forall a es ans ref ff c+     . (Shift ans ref :> es, Monad (Eff ff es), Free c ff)+    => Eff ff (CC (Op (Eff ff es ans)) ': es) a+    -> Eff ff es a+runCCOnShift = interpret \case+    SubFork -> shift \exit -> exit . Left . Op $ exit . Right+    Jump (Op exit) x -> exit x >>= abort+{-# INLINE runCCOnShift #-}

@@ -1,72 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.--module Data.Effect.ShiftReset where--import Control.Monad ((>=>))-import Data.Effect.Key (KeyH (KeyH))-import Data.Functor (void)--data Shift' (ans :: Type) n m a where-    Shift-        :: forall ans n m a-         . ((a -> n ans) -> (forall x. m x -> n x) -> n ans)-        -> Shift' ans n m a-makeKeyedEffect [] [''Shift']--callCC-    :: forall a m ans n-     . (SendHOEBy ShiftKey (Shift' ans n) m, Monad m, Monad n)-    => ((a -> n ans) -> m a)-    -> m a-callCC f = shift \k run -> run (f $ k >=> run . exit) >>= k--exit-    :: forall a m ans n-     . (SendHOEBy ShiftKey (Shift' ans n) m, Applicative n)-    => ans-    -> m a-exit ans = shift \_ _ -> pure ans-{-# INLINE exit #-}--getCC-    :: forall m ans n-     . (SendHOEBy ShiftKey (Shift' ans n) m, Monad m, Monad n)-    => m (n ans)-getCC = callCC \exit' -> let a = exit' a in pure a--embed :: forall m ans n. (SendHOEBy ShiftKey (Shift' ans n) m, Monad n) => n ~> m-embed m = shift \k _ -> m >>= k-{-# INLINE embed #-}--data Shift_' n m a where-    Shift_'-        :: (forall (ans :: Type). (a -> n ans) -> (forall x. m x -> n x) -> n ans)-        -> Shift_' n m a-makeKeyedEffect [] [''Shift_']--getCC_ :: forall m n. (SendHOEBy Shift_Key (Shift_' n) m, Functor n) => m (n ())-getCC_ = shift_' \k _ -> let k' = k $ void k' in k'--data Reset m (a :: Type) where-    Reset :: m a -> Reset m a-makeEffectH [''Reset]--data ShiftF ans a where-    ShiftF :: forall ans a. ((a -> ans) -> ans) -> ShiftF ans a-makeEffectF [''ShiftF]--fromShiftF :: ShiftF (n ans) ~> Shift ans n m-fromShiftF (ShiftF f) = KeyH $ Shift \k _ -> f k-{-# INLINE fromShiftF #-}--exitF :: forall ans m a. (ShiftF ans <: m) => ans -> m a-exitF ans = shiftF @ans $ const ans-{-# INLINE exitF #-}--embedF :: forall ans n m. (ShiftF (n ans) <: m, Monad n) => n ~> m-embedF m = shiftF @(n ans) (m >>=)-{-# INLINE embedF #-}

@@ -1,31 +1,95 @@+-- SPDX-License-Identifier: MPL-2.0 {-# LANGUAGE AllowAmbiguousTypes #-}---- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+{-# LANGUAGE QuantifiedConstraints #-}+{-# HLINT ignore "Avoid lambda" #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp  Effects for holding mutable state values in the context. -}-module Data.Effect.State where+module Data.Effect.State (+    module Data.Effect.State,+    State (..),+) where --- | An effect for holding mutable state values in the context.-data State s a where-    -- | Retrieves the current state value from the context.-    Get :: State s s-    -- | Overwrites the state value in the context.-    Put :: s -> State s ()+import Data.Effect (Ask (Ask), Emb, Local (Local), State (Get, Put))+import Data.Functor ((<&>))+import UnliftIO (newIORef, readIORef, writeIORef) -makeEffectF [''State]+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''State  -- | Retrieves the current state value from the context and returns the value transformed based on the given function.-gets :: (State s <: f, Functor f) => (s -> a) -> f a+gets :: forall s es a ff c. (State s :> es, Functor (Eff ff es), Free c ff) => (s -> a) -> Eff ff es a gets f = f <$> get+{-# INLINE gets #-}  -- | Modifies the current state value in the context based on the given function.-modify :: (State s <: m, Monad m) => (s -> s) -> m ()+modify :: forall s es ff c. (State s :> es, Monad (Eff ff es), Free c ff) => (s -> s) -> Eff ff es () modify f = put . f =<< get+{-# INLINE modify #-}++-- | Interpret the 'State' effect based on an IO-fused semantics using t'Data.IORef.IORef'.+runStateIORef+    :: forall s es ff a c+     . (Emb IO :> es, Monad (Eff ff es), Free c ff)+    => s+    -> Eff ff (State s ': es) a+    -> Eff ff es (s, a)+runStateIORef s0 m = do+    ref <- newIORef s0+    a <-+        m & interpret \case+            Get -> readIORef ref+            Put s -> writeIORef ref s+    readIORef ref <&> (,a)+{-# INLINE runStateIORef #-}++{- |+Interpret the 'State' effect based on an IO-fused semantics using t'Data.IORef.IORef'.+Do not include the final state in the return value.+-}+evalStateIORef+    :: forall s es ff a c+     . (Emb IO :> es, Monad (Eff ff es), Free c ff)+    => s+    -> Eff ff (State s ': es) a+    -> Eff ff es a+evalStateIORef s0 m = do+    ref <- newIORef s0+    m & interpret \case+        Get -> readIORef ref+        Put s -> writeIORef ref s+{-# INLINE evalStateIORef #-}++execStateIORef+    :: forall s es ff a c+     . (Emb IO :> es, Monad (Eff ff es), Free c ff)+    => s+    -> Eff ff (State s ': es) a+    -> Eff ff es s+execStateIORef s0 = fmap fst . runStateIORef s0+{-# INLINE execStateIORef #-}++localToState+    :: forall r es ff a c+     . (State r `In` es, Monad (Eff ff es), Free c ff)+    => Eff ff (Local r ': es) a+    -> Eff ff es a+localToState =+    interpret \(Local f a) -> do+        save <- get'_ @r+        put'_ $ f save+        a <* put'_ save+{-# INLINE localToState #-}++askToGet+    :: forall r es ff a c+     . (State r `In` es, Free c ff)+    => Eff ff (Ask r ': es) a+    -> Eff ff es a+askToGet = interpret \Ask -> get'_+{-# INLINE askToGet #-}

@@ -1,39 +1,49 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023-2024 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp  Realizes [@unliftio@](https://hackage.haskell.org/package/unliftio) in the form of higher-order effects. -}-module Data.Effect.Unlift where--import Data.Effect.Tag (type (##))--data UnliftBase b f (a :: Type) where-    WithRunInBase :: ((forall x. f x -> b x) -> b a) -> UnliftBase b f a+module Data.Effect.Unlift (+    module Data.Effect.Unlift,+    UnliftBase (..),+    UnliftIO,+)+where -makeEffectH [''UnliftBase]+import Control.Effect (sendAt)+import Control.Effect.Interpret (runEff)+import Data.Effect (Emb (Emb), UnliftBase (WithRunInBase), UnliftIO)+import UnliftIO qualified as IO -type UnliftIO = UnliftBase IO+makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''UnliftBase  pattern WithRunInIO :: (f ~> IO -> IO a) -> UnliftIO f a pattern WithRunInIO f = WithRunInBase f {-# COMPLETE WithRunInIO #-} -withRunInIO :: (UnliftIO <<: f) => (f ~> IO -> IO a) -> f a+withRunInIO+    :: forall es ff a c+     . (UnliftIO :> es, Free c ff)+    => (Eff ff es ~> IO -> IO a)+    -> Eff ff es a withRunInIO = withRunInBase {-# INLINE withRunInIO #-} -withRunInIO' :: forall tag f a. (UnliftIO ## tag <<: f) => (f ~> IO -> IO a) -> f a-withRunInIO' = withRunInBase' @tag-{-# INLINE withRunInIO' #-}+runUnliftBase :: forall b ff a c. (c b, Free c ff) => Eff ff '[UnliftBase b, Emb b] a -> b a+runUnliftBase =+    runEff . interpret \(WithRunInBase f) ->+        sendAt @0 $ Emb $ f runEff+{-# INLINE runUnliftBase #-} -withRunInIO'' :: forall key f a. (SendHOEBy key UnliftIO f) => (f ~> IO -> IO a) -> f a-withRunInIO'' = withRunInBase'' @key-{-# INLINE withRunInIO'' #-}+runUnliftIO :: (IO.MonadUnliftIO m, Free c ff, c m) => Eff ff '[UnliftIO, Emb m] a -> m a+runUnliftIO =+    runEff . interpret \(WithRunInBase f) ->+        sendAt @0 $ Emb $ IO.withRunInIO \run -> f $ run . runEff+{-# INLINE runUnliftIO #-}

@@ -1,54 +1,34 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors License     :  MPL-2.0 (see the file LICENSE) Maintainer  :  ymdfield@outlook.jp  Effects that can accumulate values monoidally in a context. -}-module Data.Effect.Writer where---- | An effect that can accumulate values monoidally in a context.-data Tell w a where-    -- | Accumulates new values to the cumulative value held in the context.-    Tell :: w -> Tell w ()---- | An effect that performs local operations on accumulations in the context on a per-scope basis.-data WriterH w f a where-    -- | Obtains the accumulated value in the scope and returns it together as a pair.-    Listen-        :: f a-        -- ^ The scope from which to obtain the accumulation.-        -> WriterH w f (w, a)-    -- | Modifies the accumulation in the scope based on the given function.-    Censor-        :: (w -> w)-        -- ^ A function for modifying the accumulated value.-        -> f a-        -- ^ The scope where the modification is applied.-        -> WriterH w f a+module Data.Effect.Writer (+    module Data.Effect.Writer,+    Tell (..),+    WriterH (..),+    pass,+)+where -makeEffect [''Tell] [''WriterH]+import Control.Effect (pass)+import Data.Effect (Tell (Tell), WriterH (Censor, Listen)) -{- |-For a given scope, uses the function (the first component of the pair returned-by that scope) to modify the accumulated value of that scope, and then-accumulates the result into the current outer scope.+makeEffectF_' (def & noGenerateLabel & noGenerateOrderInstance) ''Tell+makeEffectH_' (def & noGenerateLabel & noGenerateOrderInstance) ''WriterH -@-pass m = do-    (w, (f, a)) <- listen m-    tell $ f w-    pure a-@--}-pass :: (Tell w <: m, WriterH w <<: m, Monad m) => m (w -> w, a) -> m a-pass m = do-    (w, (f, a)) <- listen m-    tell $ f w-    pure a+-- | 'censor' with pre-applying semantics.+censorPre+    :: forall w es ff a c+     . (Tell w `In` es, Free c ff)+    => (w -> w)+    -> Eff ff es a+    -> Eff ff es a+censorPre f = interposeIn @(Tell w) \(Tell w) -> tell'_ $ f w+{-# INLINE censorPre #-}

@@ -1,24 +1,24 @@ {-# LANGUAGE PackageImports #-} --- This Source Code Form is subject to the terms of the Mozilla Public--- License, v. 2.0. If a copy of the MPL was not distributed with this--- file, You can obtain one at https://mozilla.org/MPL/2.0/.+-- SPDX-License-Identifier: MPL-2.0  module Prelude (     module Prelude,     module Control.Effect,-    module Control.Effect.Key,+    module Control.Effect.Interpret,+    module Data.Effect.OpenUnion,+    module Data.Effect,     module Data.Effect.TH,     module Data.Effect.HFunctor.TH,-    module Data.Effect.Key.TH,     Type,     Infinite ((:<)), ) where -import Control.Effect (type (<:), type (<<:), type (~>))-import Control.Effect.Key (SendFOEBy, SendHOEBy)+import Control.Effect (Eff, Free, type (~>), type (~~>))+import Control.Effect.Interpret (interposeIn, interpret)+import Data.Effect (Effect, LabelOf) import Data.Effect.HFunctor.TH-import Data.Effect.Key.TH (makeKeyedEffect, makeKeyedEffect_)+import Data.Effect.OpenUnion (Has, In, type (:>)) import Data.Effect.TH import Data.Kind (Type) import Data.List.Infinite (Infinite ((:<)))